Fortran: do not copy back for parameter actual arguments [PR81978]

When an array is packed for passing as an actual argument, and the array
has the PARAMETER attribute (i.e., it is a named constant that can reside
in read-only memory), do not copy back (unpack) from the temporary.

	PR fortran/81978

gcc/fortran/ChangeLog:

	* trans-array.cc (gfc_conv_array_parameter): Do not copy back data
	if actual array parameter has the PARAMETER attribute.
	* trans-expr.cc (gfc_conv_subref_array_arg): Likewise.

gcc/testsuite/ChangeLog:

	* gfortran.dg/pr81978.f90: New test.

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 44b091af2c6900603fafba552ef323405cbc67a0..ec627dddffd435056815ee79d58791b2fa163c61 100644 (file)
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -8925,6 +8925,7 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77,
   bool good_allocatable;
   bool ultimate_ptr_comp;
   bool ultimate_alloc_comp;
+  bool readonly;
   gfc_symbol *sym;
   stmtblock_t block;
   gfc_ref *ref;
@@ -9381,8 +9382,13 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77,
 
       gfc_start_block (&block);
 
-      /* Copy the data back.  */
-      if (fsym == NULL || fsym->attr.intent != INTENT_IN)
+      /* Copy the data back.  If input expr is read-only, e.g. a PARAMETER
+        array, copying back modified values is undefined behavior.  */
+      readonly = (expr->expr_type == EXPR_VARIABLE
+                 && expr->symtree
+                 && expr->symtree->n.sym->attr.flavor == FL_PARAMETER);
+
+      if ((fsym == NULL || fsym->attr.intent != INTENT_IN) && !readonly)
        {
          if (ctree)
            {

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index bef49d32a5899419efa588e109735770c5d30291..dcf42d53175631a1def5f0b8b5dfc32d5029ecd1 100644 (file)
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -5200,6 +5200,7 @@ gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
   gfc_se work_se;
   gfc_se *parmse;
   bool pass_optional;
+  bool readonly;
 
   pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
 
@@ -5416,8 +5417,14 @@ gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
 
   /* Wrap the whole thing up by adding the second loop to the post-block
      and following it by the post-block of the first loop.  In this way,
-     if the temporary needs freeing, it is done after use!  */
-  if (intent != INTENT_IN)
+     if the temporary needs freeing, it is done after use!
+     If input expr is read-only, e.g. a PARAMETER array, copying back
+     modified values is undefined behavior.  */
+  readonly = (expr->expr_type == EXPR_VARIABLE
+             && expr->symtree
+             && expr->symtree->n.sym->attr.flavor == FL_PARAMETER);
+
+  if ((intent != INTENT_IN) && !readonly)
     {
       gfc_add_block_to_block (&parmse->post, &loop2.pre);
       gfc_add_block_to_block (&parmse->post, &loop2.post);

diff --git a/gcc/testsuite/gfortran.dg/pr81978.f90 b/gcc/testsuite/gfortran.dg/pr81978.f90
new file mode 100644 (file)
index 0000000..b377eef
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr81978.f90
@@ -0,0 +1,107 @@
+! { dg-do run }
+! PR fortran/81978 - do not copy back for parameter actual arguments
+
+module test_mod
+  implicit none
+
+  type pp_struct
+     character(10) :: name
+     real          :: value
+  end type pp_struct
+
+  type(pp_struct), parameter :: pp(4) = [ &
+       pp_struct('one',   1.), &
+       pp_struct('two',   2.), &
+       pp_struct('three', 3.), &
+       pp_struct('four',  4.)  ]
+
+contains
+
+  subroutine match_word (names)
+    character(*)        :: names(:)
+  end subroutine match_word
+
+  subroutine sub0 (a)
+    real                :: a(:)
+  end
+
+  subroutine sub1 (a, n)
+    integer, intent(in) :: n
+    real                :: a(n)
+  end
+
+  subroutine subx (a)
+    real                :: a(..)
+  end
+end module
+
+program test
+  use test_mod
+  implicit none
+  integer :: i, n
+  integer, parameter :: m = 8
+  real,    parameter :: x(m) = [(i,i=1,m)]
+
+  n = size (x)
+  call sub0 (x)
+  call sub1 (x, n)
+  call sub2 (x, n)
+  call subx (x)
+
+  i = 1
+  call sub0 (x(1::i))
+  call sub1 (x(1::i), n)
+  call sub2 (x(1::i), n)
+  call subx (x(1::i))
+
+  n = size (x(1::2))
+  call sub0 (x(1::2))
+  call sub1 (x(1::2), n)
+  call sub2 (x(1::2), n)
+  call subx (x(1::2))
+
+  i = 2
+  call sub0 (x(1::i))
+  call sub1 (x(1::i), n)
+  call sub2 (x(1::i), n)
+  call subx (x(1::i))
+
+  call match_word (pp%name)
+  call sub0       (pp%value)
+  call subx       (pp%value)
+  call match_word (pp(1::2)%name)
+  call sub0       (pp(1::2)%value)
+  call subx       (pp(1::2)%value)
+  i = 1
+  call match_word (pp(1::i)%name)
+  call sub0       (pp(1::i)%value)
+  call subx       (pp(1::i)%value)
+  i = 2
+  call match_word (pp(1::i)%name)
+  call sub0       (pp(1::i)%value)
+  call subx       (pp(1::i)%value)
+
+  call foo  (pp%name,        size(pp%name))
+  call foo  (pp(1::2)%name,  size(pp(1::2)%name))
+  call sub1 (pp(1::2)%value, size(pp(1::2)%value))
+  call sub2 (pp(1::2)%value, size(pp(1::2)%value))
+  i = 1
+  call foo  (pp(1::i)%name,  size(pp(1::i)%name))
+  call sub1 (pp(1::i)%value, size(pp(1::i)%value))
+  call sub2 (pp(1::i)%value, size(pp(1::i)%value))
+  i = 2
+  call foo  (pp(1::i)%name,  size(pp(1::i)%name))
+  call sub1 (pp(1::i)%value, size(pp(1::i)%value))
+  call sub2 (pp(1::i)%value, size(pp(1::i)%value))
+end program
+
+subroutine sub2 (a, n)
+  integer, intent(in) :: n
+  real                :: a(n)
+end
+
+subroutine foo (s, n)
+  integer, intent(in) :: n
+  character(*)        :: s(*)
+! print *, len(s), n, s(n)
+end