[Ada] Problem with boundary case of XOR operation and unnesting

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.

2018-11-14  Ed Schonberg  <schonberg@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.

From-SVN: r266137

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 14cc1fd..d600411 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,12 @@
+2018-11-14  Ed Schonberg  <schonberg@adacore.com>
+
+       * 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.
+
 2018-11-14  Patrick Bernardi  <bernardi@adacore.com>
 
        * libgnarl/a-intnam__linux.ads: Add SIGSYS.

diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index a00e0c7..9cf2d3e 100644 (file)
--- a/gcc/ada/exp_ch4.adb
+++ b/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

diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb
index 7e5e337..632c3bd 100644 (file)
--- a/gcc/ada/exp_pakd.adb
+++ b/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

diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index a76e92e..b5338d4 100644 (file)
--- a/gcc/ada/exp_util.adb
+++ b/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;
 

diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index 7c2d9b7..9b76ef8 100644 (file)
--- a/gcc/ada/exp_util.ads
+++ b/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;