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

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@266137 138bc75d-0d04-0410-961f-82ee72b054a4

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 14cc1fd3fd7bd05b787b06f382430ccf78c4bd0a..d6004111e65f382644ba8268992123bb31f1b05b 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 a00e0c7761d1fa1621a8801f335177443551db99..9cf2d3e410b7d18a88af5c0cbf27e7039c50cf3a 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 7e5e337b06c5c89ffe6cb7d71a394ef1df602891..632c3bd6350eead4b88ce390c93ad0a7304bfd9b 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 a76e92e7e444465135cd8339c243fa357e7c6655..b5338d4deb2c49ae5e1c9ae18ad40fc9f529e44c 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 7c2d9b72ec628bb0222bf6764b0264e6a14f6d29..9b76ef88a2d5bf6516762e3ff0aad5766ec25436 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;