Fix wrong assignment to mutable Out parameter of task entry

Under very specific circumstances the compiler can generate a wrong
assignment to a mutable record object which contains an array component,
because it does not correctly handle the update of the discriminant.

gcc/ada/ChangeLog
	* gcc-interface/gigi.h (operand_type): New static inline function.
	* gcc-interface/trans.c (gnat_to_gnu): Do not suppress conversion
	to the resulty type at the end for array types.
	* gcc-interface/utils2.c (build_binary_op) <MODIFY_EXPR>: Do not
	remove conversions between array types on the LHS.

gcc/testsuite/ChangeLog
	* gnat.dg/array39.adb: New test.
	* gnat.dg/array39_pkg.ads: New helper.
	* gnat.dg/array39_pkg.adb: Likewise.

diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h
index fcdea320c3aadac2a35c8262516c65ce94bce43a..e43b3db59a992de7fc5e313182aaeaa44a8f2a0f 100644 (file)
--- a/gcc/ada/gcc-interface/gigi.h
+++ b/gcc/ada/gcc-interface/gigi.h
@@ -1209,3 +1209,11 @@ maybe_padded_object (tree expr)
 
   return expr;
 }
+
+/* Return the type of operand #0 of EXPR.  */
+
+static inline tree
+operand_type (tree expr)
+{
+  return TREE_TYPE (TREE_OPERAND (expr, 0));
+}

diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c
index b7a4cadb7e62191629477386712282247139c020..969a480c3da29d29800f31d9def1639ea59b274c 100644 (file)
--- a/gcc/ada/gcc-interface/trans.c
+++ b/gcc/ada/gcc-interface/trans.c
@@ -8821,7 +8821,8 @@ gnat_to_gnu (Node_Id gnat_node)
        1. If this is the LHS of an assignment or an actual parameter of a
          call, return the result almost unmodified since the RHS will have
          to be converted to our type in that case, unless the result type
-         has a simpler size.  Likewise if there is just a no-op unchecked
+         has a simpler size or for array types because this size might be
+         changed in-between. Likewise if there is just a no-op unchecked
          conversion in-between.  Similarly, don't convert integral types
          that are the operands of an unchecked conversion since we need
          to ignore those conversions (for 'Valid).
@@ -8856,15 +8857,17 @@ gnat_to_gnu (Node_Id gnat_node)
              && !AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))))
       && !(TYPE_SIZE (gnu_result_type)
           && TYPE_SIZE (TREE_TYPE (gnu_result))
-          && (AGGREGATE_TYPE_P (gnu_result_type)
-              == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result)))
+          && AGGREGATE_TYPE_P (gnu_result_type)
+             == AGGREGATE_TYPE_P (TREE_TYPE (gnu_result))
           && ((TREE_CODE (TYPE_SIZE (gnu_result_type)) == INTEGER_CST
                && (TREE_CODE (TYPE_SIZE (TREE_TYPE (gnu_result)))
                    != INTEGER_CST))
               || (TREE_CODE (TYPE_SIZE (gnu_result_type)) != INTEGER_CST
                   && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_result_type))
                   && (CONTAINS_PLACEHOLDER_P
-                      (TYPE_SIZE (TREE_TYPE (gnu_result))))))
+                      (TYPE_SIZE (TREE_TYPE (gnu_result)))))
+              || (TREE_CODE (gnu_result_type) == ARRAY_TYPE
+                  && TREE_CODE (TREE_TYPE (gnu_result)) == ARRAY_TYPE))
           && !(TREE_CODE (gnu_result_type) == RECORD_TYPE
                && TYPE_JUSTIFIED_MODULAR_P (gnu_result_type))))
     {

diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c
index 7799776e1db0c23e2cff05d2f0f74a2411df4842..a18d50f8f00f6cd273b4178f1b16be1520762a4d 100644 (file)
--- a/gcc/ada/gcc-interface/utils2.c
+++ b/gcc/ada/gcc-interface/utils2.c
@@ -875,31 +875,21 @@ build_binary_op (enum tree_code op_code, tree result_type,
 
       /* If there were integral or pointer conversions on the LHS, remove
         them; we'll be putting them back below if needed.  Likewise for
-        conversions between array and record types, except for justified
-        modular types.  But don't do this if the right operand is not
-        BLKmode (for packed arrays) unless we are not changing the mode.  */
+        conversions between record types, except for justified modular types.
+        But don't do this if the right operand is not BLKmode (for packed
+        arrays) unless we are not changing the mode.  */
       while ((CONVERT_EXPR_P (left_operand)
              || TREE_CODE (left_operand) == VIEW_CONVERT_EXPR)
             && (((INTEGRAL_TYPE_P (left_type)
                   || POINTER_TYPE_P (left_type))
-                 && (INTEGRAL_TYPE_P (TREE_TYPE
-                                      (TREE_OPERAND (left_operand, 0)))
-                     || POINTER_TYPE_P (TREE_TYPE
-                                        (TREE_OPERAND (left_operand, 0)))))
-                || (((TREE_CODE (left_type) == RECORD_TYPE
-                      && !TYPE_JUSTIFIED_MODULAR_P (left_type))
-                     || TREE_CODE (left_type) == ARRAY_TYPE)
-                    && ((TREE_CODE (TREE_TYPE
-                                    (TREE_OPERAND (left_operand, 0)))
-                         == RECORD_TYPE)
-                        || (TREE_CODE (TREE_TYPE
-                                       (TREE_OPERAND (left_operand, 0)))
-                            == ARRAY_TYPE))
+                 && (INTEGRAL_TYPE_P (operand_type (left_operand))
+                     || POINTER_TYPE_P (operand_type (left_operand))))
+                || (TREE_CODE (left_type) == RECORD_TYPE
+                    && !TYPE_JUSTIFIED_MODULAR_P (left_type)
+                    && TREE_CODE (operand_type (left_operand)) == RECORD_TYPE
                     && (TYPE_MODE (right_type) == BLKmode
-                        || (TYPE_MODE (left_type)
-                            == TYPE_MODE (TREE_TYPE
-                                          (TREE_OPERAND
-                                           (left_operand, 0))))))))
+                        || TYPE_MODE (left_type)
+                           == TYPE_MODE (operand_type (left_operand))))))
        {
          left_operand = TREE_OPERAND (left_operand, 0);
          left_type = TREE_TYPE (left_operand);
@@ -921,8 +911,7 @@ build_binary_op (enum tree_code op_code, tree result_type,
               && TREE_CONSTANT (TYPE_SIZE (left_type))
               && ((TREE_CODE (right_operand) == COMPONENT_REF
                    && TYPE_MAIN_VARIANT (left_type)
-                      == TYPE_MAIN_VARIANT
-                         (TREE_TYPE (TREE_OPERAND (right_operand, 0))))
+                      == TYPE_MAIN_VARIANT (operand_type (right_operand)))
                   || (TREE_CODE (right_operand) == CONSTRUCTOR
                       && !CONTAINS_PLACEHOLDER_P
                           (DECL_SIZE (TYPE_FIELDS (left_type)))))
@@ -976,22 +965,23 @@ build_binary_op (enum tree_code op_code, tree result_type,
              || TREE_CODE (result) == ARRAY_RANGE_REF)
            while (handled_component_p (result))
              result = TREE_OPERAND (result, 0);
+
          else if (TREE_CODE (result) == REALPART_EXPR
                   || TREE_CODE (result) == IMAGPART_EXPR
                   || (CONVERT_EXPR_P (result)
                       && (((TREE_CODE (restype)
-                            == TREE_CODE (TREE_TYPE
-                                          (TREE_OPERAND (result, 0))))
-                            && (TYPE_MODE (TREE_TYPE
-                                           (TREE_OPERAND (result, 0)))
-                                == TYPE_MODE (restype)))
+                            == TREE_CODE (operand_type (result))
+                            && TYPE_MODE (restype)
+                                == TYPE_MODE (operand_type (result))))
                           || TYPE_ALIGN_OK (restype))))
            result = TREE_OPERAND (result, 0);
+
          else if (TREE_CODE (result) == VIEW_CONVERT_EXPR)
            {
              TREE_ADDRESSABLE (result) = 1;
              result = TREE_OPERAND (result, 0);
            }
+
          else
            break;
        }

diff --git a/gcc/testsuite/gnat.dg/array39.adb b/gcc/testsuite/gnat.dg/array39.adb
new file mode 100644 (file)
index 0000000..3e886c1
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/array39.adb
@@ -0,0 +1,13 @@
+-- { dg-do run }
+
+with Array39_Pkg; use Array39_Pkg;
+
+procedure Array39 is
+  T : Tsk;
+  R : Rec2;
+begin
+  T.E (R, 1);
+  if R.A (1) /= Val then
+    raise Program_Error;
+  end if;
+end;

diff --git a/gcc/testsuite/gnat.dg/array39_pkg.adb b/gcc/testsuite/gnat.dg/array39_pkg.adb
new file mode 100644 (file)
index 0000000..32fe8e2
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/array39_pkg.adb
@@ -0,0 +1,20 @@
+package body Array39_Pkg is
+
+  task Body Tsk is
+  begin
+    select
+      accept E (R : out Rec2; L : Index2) do
+      declare
+        A  : Arr2 (Index2);
+        LL : Index2 := L;
+      begin
+        for I in 1 .. LL loop
+          A (I) := Val;
+        end loop;
+        R := (D => LL, A => A (1 .. LL));
+      end;
+      end E;
+    end select;
+  end Tsk;
+
+end Array39_Pkg;

diff --git a/gcc/testsuite/gnat.dg/array39_pkg.ads b/gcc/testsuite/gnat.dg/array39_pkg.ads
new file mode 100644 (file)
index 0000000..e5cc4b8
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/array39_pkg.ads
@@ -0,0 +1,25 @@
+package Array39_Pkg is
+
+  subtype Index1 is Natural range 0 .. 2;
+
+  type Arr1 is array (Index1 range <>) of Integer;
+
+  type Rec1 (D : Index1 := 0) is record
+    A : Arr1 (1 .. D);
+  end record;
+
+  subtype Index2 is Natural range 0 .. 7;
+
+  type Arr2 is array (Index2 range <>) of Rec1;
+
+  type Rec2 (D : Index2 := 0) is record
+    A : Arr2 (1 .. D);
+  end record;
+
+  Val : Rec1 := (D => 1, A => (others => 1));
+
+  task type Tsk is
+    entry E (R : out Rec2; L : Index2);
+  end Tsk;
+
+end Array39_Pkg;