re PR fortran/50069 (FORALL fails on a character array)

2017-01-18  Louis Krupp  <louis.krupp@zoho.com>

	PR fortran/50069
	PR fortran/55086
	* gfortran.dg/pr50069_1.f90: New test.
	* gfortran.dg/pr50069_2.f90: New test.
	* gfortran.dg/pr55086_1.f90: New test.
	* gfortran.dg/pr55086_1_tfat.f90: New test.
	* gfortran.dg/pr55086_2.f90: New test.
	* gfortran.dg/pr55086_2_tfat.f90: New test.
	* gfortran.dg/pr55086_aliasing_dummy_4_tfat.f90: New test.

2017-01-18  Louis Krupp  <louis.krupp@zoho.com>

	PR fortran/50069
	PR fortran/55086
	* trans-expr.c (gfc_conv_variable): Don't treat temporary variables
	as function arguments.
	* trans-stmt.c (forall_make_variable_temp,
	generate_loop_for_temp_to_lhs, gfc_trans_assign_need_temp,
	gfc_trans_forall_1): Don't adjust offset of forall temporary
	for array sections, make forall temporaries work for substring
	expressions, improve test coverage by adding -ftest-forall-temp
	option to request usage of temporary array in forall code.
	* lang.opt: Add -ftest-forall-temp option.
	* invoke.texi: Add -ftest-forall-temp option.

From-SVN: r244601

gcc/fortran/ChangeLog

+2017-01-18  Louis Krupp  <louis.krupp@zoho.com>
+
+	PR fortran/50069
+	PR fortran/55086
+	* trans-expr.c (gfc_conv_variable): Don't treat temporary variables
+	as function arguments.
+	* trans-stmt.c (forall_make_variable_temp,
+	generate_loop_for_temp_to_lhs, gfc_trans_assign_need_temp,
+	gfc_trans_forall_1): Don't adjust offset of forall temporary
+	for array sections, make forall temporaries work for substring
+	expressions, improve test coverage by adding -ftest-forall-temp
+	option to request usage of temporary array in forall code.
+	* lang.opt: Add -ftest-forall-temp option.
+	* invoke.texi: Add -ftest-forall-temp option.
+
 2017-01-18  Andre Vehreschild  <vehre@gcc.gnu.org>
 
 	* primary.c (caf_variable_attr): Improve figuring whether the current

gcc/fortran/invoke.texi

@@ -124,6 +124,7 @@ by type.  Explanations are in the following sections.
 -fmax-identifier-length -fmodule-private -ffixed-form -fno-range-check @gol
 -fopenacc -fopenmp -freal-4-real-10 -freal-4-real-16 -freal-4-real-8 @gol
 -freal-8-real-10 -freal-8-real-16 -freal-8-real-4 -std=@var{std}
+-ftest-forall-temp
 }
 
 @item Preprocessing Options
@@ -459,6 +460,10 @@ allows the Fortran 2008 standard including the additions of the
 Technical Specification (TS) 29113 on Further Interoperability of Fortran
 with C and TS 18508 on Additional Parallel Features in Fortran.
 
+@item -ftest-forall-temp
+@opindex @code{ftest-forall-temp}
+Enhance test coverage by forcing most forall assignments to use temporary.
+
 @end table
 
 @node Preprocessing Options

gcc/fortran/lang.opt

@@ -488,6 +488,10 @@ ffixed-form
 Fortran RejectNegative
 Assume that the source file is fixed form.
 
+ftest-forall-temp
+Fortran Var(flag_test_forall_temp) Init(0)
+Force creation of temporary to test infrequently-executed forall code
+
 finteger-4-integer-8
 Fortran RejectNegative Var(flag_integer4_kind,8)
 Interpret any INTEGER(4) as an INTEGER(8).

gcc/fortran/trans-expr.c

@@ -2544,8 +2544,10 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
       if (se_expr)
 	se->expr = se_expr;
 
-      /* Procedure actual arguments.  */
-      else if (sym->attr.flavor == FL_PROCEDURE
+      /* Procedure actual arguments.  Look out for temporary variables
+	 with the same attributes as function values.  */
+      else if (!sym->attr.temporary
+	       && sym->attr.flavor == FL_PROCEDURE
 	       && se->expr != current_function_decl)
 	{
 	  if (!sym->attr.dummy && !sym->attr.proc_pointer)

gcc/testsuite/ChangeLog

+2017-01-18  Louis Krupp  <louis.krupp@zoho.com>
+
+	PR fortran/50069
+	PR fortran/55086
+	* gfortran.dg/pr50069_1.f90: New test.
+	* gfortran.dg/pr50069_2.f90: New test.
+	* gfortran.dg/pr55086_1.f90: New test.
+	* gfortran.dg/pr55086_1_tfat.f90: New test.
+	* gfortran.dg/pr55086_2.f90: New test.
+	* gfortran.dg/pr55086_2_tfat.f90: New test.
+	* gfortran.dg/pr55086_aliasing_dummy_4_tfat.f90: New test.
+
 2017-01-18  Aaron Sawdey  <acsawdey@linux.vnet.ibm.com>
 	* gcc.dg/strcmp-1.c: New test.
 	* gcc.dg/strncmp-1.c: Add test for a bug that escaped.

gcc/testsuite/gfortran.dg/pr50069_1.f90

+! { dg-do run }
+
+  implicit none
+  integer i
+  character(LEN=6) :: a(1) = "123456"
+  forall (i = 3:4) a(1)(i:i+2) = a(1)(i-2:i)
+  !print *,a ! displays '12@' must be '121234'
+  IF (a(1) .ne. "121234") call abort
+end

gcc/testsuite/gfortran.dg/pr50069_2.f90

+! { dg-do compile }
+
+function reverse(string)
+implicit none
+character(len=*), intent(in) :: string
+character(len=:),allocatable :: reverse
+integer i
+reverse = string
+forall (i=1:len(reverse)) reverse(i:i) = &
+  reverse(len(reverse)-i+1:len(reverse)-i+1)
+end function reverse

gcc/testsuite/gfortran.dg/pr55086_1.f90

+! { dg-do run }
+!
+  implicit none
+  character(len=5), pointer :: a(:), b(:)
+  character(len=5), pointer :: c, d
+  allocate (a(2), b(2), c, d)
+  a = [ "abcde", "ABCDE" ]
+  call aloct_pointer_copy_4 (b, a)
+  !print *, b(1)
+  !print *, b(2)
+  if (any (a /= b)) stop 'WRONG'
+
+  call aloct_copy_4 (b, a)
+  !print *, b(1)
+  !print *, b(2)
+  if (any (a /= b)) stop 'WRONG'
+
+  d = '12345'
+  c = "abcde"
+  call test2 (d, c)
+  !print *, d
+  if (d /= '1cb15') stop 'WRONG'
+
+  call test2p (d, c)
+  !print *, d
+  if (d /= '1cb15') stop 'WRONG'
+
+contains
+ subroutine aloct_pointer_copy_4(o, i)
+  character(len=*), pointer :: o(:), i(:)
+  integer :: nl1, nu1
+  integer :: i1
+  nl1 = lbound(i,dim=1)
+  nu1 = ubound(i,dim=1)
+  forall (i1 = nl1:nu1) o(i1) = i(i1)
+ end subroutine aloct_pointer_copy_4
+ subroutine aloct_copy_4(o, i)
+  character(len=*), pointer :: o(:), i(:)
+  integer :: nl1, nu1
+  integer :: i1
+  nl1 = lbound(i,dim=1)
+  nu1 = ubound(i,dim=1)
+  forall (i1 = nl1:nu1) o(i1) = i(i1)
+ end subroutine aloct_copy_4
+ subroutine test2(o, i)
+  character(len=*) :: o, i
+  integer :: nl1, nu1
+  integer :: i1
+  nl1 = 2
+  nu1 = 4
+  forall (i1 = nl1:nu1) o(i1:i1) = i(i1:i1)
+  forall (i1 = nl1:nu1) o(i1:i1) = o(nu1+1-i1:nu1+1-i1)
+ end subroutine test2
+ subroutine test2p(o, i)
+  character(len=*), pointer :: o, i
+  integer :: nl1, nu1
+  integer :: i1
+  nl1 = 2
+  nu1 = 4
+  forall (i1 = nl1:nu1) o(i1:i1) = i(i1:i1)   ! <<<< ICE
+  forall (i1 = nl1:nu1) o(i1:i1) = o(nu1+1-i1:nu1+1-i1)
+ end subroutine test2p
+end

gcc/testsuite/gfortran.dg/pr55086_1_tfat.f90

+! { dg-do run }
+! { dg-options "-ftest-forall-temp" }
+!
+  implicit none
+  character(len=5), pointer :: a(:), b(:)
+  character(len=5), pointer :: c, d
+  allocate (a(2), b(2), c, d)
+  a = [ "abcde", "ABCDE" ]
+  call aloct_pointer_copy_4 (b, a)
+  !print *, b(1)
+  !print *, b(2)
+  if (any (a /= b)) stop 'WRONG'
+
+  call aloct_copy_4 (b, a)
+  !print *, b(1)
+  !print *, b(2)
+  if (any (a /= b)) stop 'WRONG'
+
+  d = '12345'
+  c = "abcde"
+  call test2 (d, c)
+  !print *, d
+  if (d /= '1cb15') stop 'WRONG'
+
+  call test2p (d, c)
+  !print *, d
+  if (d /= '1cb15') stop 'WRONG'
+
+contains
+ subroutine aloct_pointer_copy_4(o, i)
+  character(len=*), pointer :: o(:), i(:)
+  integer :: nl1, nu1
+  integer :: i1
+  nl1 = lbound(i,dim=1)
+  nu1 = ubound(i,dim=1)
+  forall (i1 = nl1:nu1) o(i1) = i(i1)
+ end subroutine aloct_pointer_copy_4
+ subroutine aloct_copy_4(o, i)
+  character(len=*), pointer :: o(:), i(:)
+  integer :: nl1, nu1
+  integer :: i1
+  nl1 = lbound(i,dim=1)
+  nu1 = ubound(i,dim=1)
+  forall (i1 = nl1:nu1) o(i1) = i(i1)
+ end subroutine aloct_copy_4
+ subroutine test2(o, i)
+  character(len=*) :: o, i
+  integer :: nl1, nu1
+  integer :: i1
+  nl1 = 2
+  nu1 = 4
+  forall (i1 = nl1:nu1) o(i1:i1) = i(i1:i1)
+  forall (i1 = nl1:nu1) o(i1:i1) = o(nu1+1-i1:nu1+1-i1)
+ end subroutine test2
+ subroutine test2p(o, i)
+  character(len=*), pointer :: o, i
+  integer :: nl1, nu1
+  integer :: i1
+  nl1 = 2
+  nu1 = 4
+  forall (i1 = nl1:nu1) o(i1:i1) = i(i1:i1)   ! <<<< ICE
+  forall (i1 = nl1:nu1) o(i1:i1) = o(nu1+1-i1:nu1+1-i1)
+ end subroutine test2p
+end

gcc/testsuite/gfortran.dg/pr55086_2.f90

+! { dg-do run }
+!
+  implicit none
+
+  character(len=7), pointer :: u
+  character(len=7), pointer :: v
+
+  character(len=7), target  :: a
+  character(len=7), target  :: b
+
+  integer :: j
+
+  b = "1234567"
+  a = "abcdefg"
+
+  u => a
+  v => b
+
+  forall (j = 1:2) a(j:j) = b(j:j)
+
+  if (a /= "12cdefg") call abort
+
+  forall (j = 2:3) a(j:j) = v(j:j)
+  if (a /= "123defg") call abort
+
+  forall (j = 3:4) u(j:j) = b(j:j)
+  if (a /= "1234efg") call abort
+
+  forall (j = 4:5) u(j:j) = v(j:j)
+  if (a /= "12345fg") call abort
+
+end

gcc/testsuite/gfortran.dg/pr55086_2_tfat.f90

+! { dg-do run }
+! { dg-options "-ftest-forall-temp" }
+!
+  implicit none
+
+  character(len=7), pointer :: u
+  character(len=7), pointer :: v
+
+  character(len=7), target  :: a
+  character(len=7), target  :: b
+
+  integer :: j
+
+  b = "1234567"
+  a = "abcdefg"
+
+  u => a
+  v => b
+
+  forall (j = 1:2) a(j:j) = b(j:j)
+
+  if (a /= "12cdefg") call abort
+
+  forall (j = 2:3) a(j:j) = v(j:j)
+  if (a /= "123defg") call abort
+
+  forall (j = 3:4) u(j:j) = b(j:j)
+  if (a /= "1234efg") call abort
+
+  forall (j = 4:5) u(j:j) = v(j:j)
+  if (a /= "12345fg") call abort
+
+end

gcc/testsuite/gfortran.dg/pr55086_aliasing_dummy_4_tfat.f90

+! { dg-do run }
+! { dg-options "-ftest-forall-temp" }
+! This is a copy of aliasing_dummy_4.f90, with an option set to improve
+! test coverage by forcing forall code to use a temporary.
+!
+program  test_f90
+
+    integer, parameter :: N = 2
+
+    type test_type
+        integer a(N, N)
+    end type
+
+    type (test_type) s(N, N)
+
+    forall (l = 1:N, m = 1:N) &
+        s(l, m)%a(:, :) = reshape ([((i*l + 10*j*m +100, i = 1, N), j = 1, N)], [N, N])
+
+    call test_sub(s%a(1, 1), 1000) ! Test the original problem.
+
+    if ( any (s(1, 1)%a(:, :) /= reshape ([1111, 112, 121, 122], [2, 2]))) call abort ()
+    if ( any (s(1, 2)%a(:, :) /= reshape ([1121, 122, 141, 142], [2, 2]))) call abort ()
+    if ( any (s(2, 1)%a(:, :) /= reshape ([1112, 114, 122, 124], [2, 2]))) call abort ()
+    if ( any (s(2, 2)%a(:, :) /= reshape ([1122, 124, 142, 144], [2, 2]))) call abort ()
+
+    call test_sub(s(1, 1)%a(:, :), 1000)  ! Check "normal" references.
+
+    if ( any (s(1, 1)%a(:, :) /= reshape ([2111,1112,1121,1122], [2, 2]))) call abort ()
+    if ( any (s(1, 2)%a(:, :) /= reshape ([1121, 122, 141, 142], [2, 2]))) call abort ()
+    if ( any (s(2, 1)%a(:, :) /= reshape ([1112, 114, 122, 124], [2, 2]))) call abort ()
+    if ( any (s(2, 2)%a(:, :) /= reshape ([1122, 124, 142, 144], [2, 2]))) call abort ()
+contains
+  subroutine test_sub(array, offset)
+    integer array(:, :), offset
+
+    forall (i = 1:N, j = 1:N) &
+        array(i, j) = array(i, j) + offset
+  end subroutine
+end program
+