Fortran] PR91640 – Fix call to contiguous dummy

        PR fortran/91640
        * trans-expr.c (gfc_conv_procedure_call): Avoid copy-out for nonvariable
        arguments to contiguous dummy args.  Avoid re-checking whether fsym is
        NULL.

        PR fortran/91640
        * gfortran.dg/contiguous_10.f90: New.

From-SVN: r279879

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 19397d6..a09d370 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2020-01-04  Tobias Burnus  <tobias@codesourcery.com>
+
+       PR fortran/91640
+       * trans-expr.c (gfc_conv_procedure_call): Avoid copy-out for nonvariable
+       arguments to contiguous dummy args.  Avoid re-checking whether fsym is
+       NULL.
+
 2020-01-03  Tobias Burnus  <tobias@codesourcery.com>
 
        * trans-openmp.c (gfc_omp_check_optional_argument): Always return a

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index f2fe538..e1c0fb2 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -6178,7 +6178,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
                                fsym && fsym->attr.pointer);
 
              else if (gfc_is_class_array_ref (e, NULL)
-                        && fsym && fsym->ts.type == BT_DERIVED)
+                      && fsym && fsym->ts.type == BT_DERIVED)
                /* The actual argument is a component reference to an
                   array of derived types.  In this case, the argument
                   is converted to a temporary, which is passed and then
@@ -6187,26 +6187,26 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
                   the same as the declared type, copy-in/copy-out does
                   not occur.  */
                gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
-                               fsym ? fsym->attr.intent : INTENT_INOUT,
-                               fsym && fsym->attr.pointer);
+                                          fsym->attr.intent,
+                                          fsym->attr.pointer);
 
              else if (gfc_is_class_array_function (e)
-                        && fsym && fsym->ts.type == BT_DERIVED)
+                      && fsym && fsym->ts.type == BT_DERIVED)
                /* See previous comment.  For function actual argument,
                   the write out is not needed so the intent is set as
                   intent in.  */
                {
                  e->must_finalize = 1;
                  gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
-                                            INTENT_IN,
-                                            fsym && fsym->attr.pointer);
+                                            INTENT_IN, fsym->attr.pointer);
                }
              else if (fsym && fsym->attr.contiguous
-                      && !gfc_is_simply_contiguous (e, false, true))
+                      && !gfc_is_simply_contiguous (e, false, true)
+                      && gfc_expr_is_variable (e))
                {
                  gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
-                               fsym ? fsym->attr.intent : INTENT_INOUT,
-                               fsym && fsym->attr.pointer);
+                                            fsym->attr.intent,
+                                            fsym->attr.pointer);
                }
              else
                gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index a5339e1..18f1479 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2020-01-04  Tobias Burnus  <tobias@codesourcery.com>
+
+       PR fortran/91640
+       * gfortran.dg/contiguous_10.f90: New.
+
 2020-01-03  Iain Sandoe  <iain@sandoe.co.uk>
 
        * gcc.target/i386/avx512bw-pr92686-vpcmp-intelasm-1.c: Require

diff --git a/gcc/testsuite/gfortran.dg/contiguous_10.f90 b/gcc/testsuite/gfortran.dg/contiguous_10.f90
new file mode 100644 (file)
index 0000000..82b8ed5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/contiguous_10.f90
@@ -0,0 +1,69 @@
+! { dg-do run }
+! { dg-additional-options "-fdump-tree-original" }
+!
+! PR fortran/91640
+!
+! Based on G. Steinmetz's test case
+!
+program p
+   implicit none (type, external)
+   real, target :: z(3) = 1.0
+   real :: res(3)
+   real, pointer :: xxx(:)
+
+   res = 42.0
+   call sub (-z, res)
+   if (any (abs (res - (-1.0)) > epsilon(res))) stop 1
+   if (any (abs (z - 1.0) > epsilon(z))) stop 2
+
+   res = 43.0
+   call sub (z*2.0, res)
+   if (any (abs (res - 2.0) > epsilon(res))) stop 3
+   if (any (abs (z - 1.0) > epsilon(z))) stop 4
+
+   res = 44.0
+   call sub(get_var(), res)
+   if (any (abs (res - 1.0) > epsilon(res))) stop 5
+   if (any (abs (z - 1.0) > epsilon(z))) stop 6
+
+   call double(get_var())
+   if (any (abs (z - 2.0) > epsilon(z))) stop 7
+
+   call double(get_var_cont())
+   if (any (abs (z - 4.0) > epsilon(z))) stop 8
+
+   ! For cross check for copy-out:
+   xxx => z
+   if (any (abs (z - 4.0) > epsilon(z))) stop 10
+   if (any (abs (xxx - 4.0) > epsilon(z))) stop 11
+   call double (xxx)
+   if (any (abs (z - 8.0) > epsilon(z))) stop 12
+   if (any (abs (xxx - 8.0) > epsilon(z))) stop 13
+
+contains
+   subroutine sub (x, res)
+      real, contiguous :: x(:)
+      real :: res(3)
+      res = x
+   end
+   subroutine double (x)
+      real, contiguous :: x(:)
+      x = x * 2.0
+   end
+   function get_var()
+     real, pointer :: get_var(:)
+     get_var => z
+   end
+   function get_var_cont()
+     real, pointer, contiguous :: get_var_cont(:)
+     get_var_cont => z
+   end
+end
+
+! only 'xxx' should have a copy out:
+! { dg-final { scan-tree-dump-times "D\\.\[0-9\].* = .*atmp\\.\[0-9\]*\\.data" 1 "original" } }
+! { dg-final { scan-tree-dump-times "D\\.\[0-9\].*xxx\\.span.* = .*atmp\\.\[0-9\]*\\.data" 1 "original" } }
+
+! Only once 'z... = ' – for:   static real(kind=4) z[3] = {[0 ... 2]=1.0e+0};
+! but don't match '(si)ze'
+! { dg-final { scan-tree-dump-times "z\[^e\].* = " 1 "original" } }