re PR fortran/33139 (array pointer assignment gives incorrect dimensions)

2007-08-24  Tobias Burnus  <burnus@net-b.de>

	PR fortran/33139
	* trans-array.c (gfc_conv_expr_descriptor): Copy bounds for
	whole-array pointer assignments.

2007-08-24  Tobias Burnus  <burnus@net-b.de>

	PR fortran/33139
	* gfortran.dg/pointer_assign_4.f90: New.
	* gfortran.dg/shape_2.f90: Fix test case.
	* gfortran.dg/char_result_4.f90: Ditto.

From-SVN: r127770

gcc/fortran/ChangeLog

+2007-08-24  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/33139
+	* trans-array.c (gfc_conv_expr_descriptor): Copy bounds for
+	whole-array pointer assignments.
+
 2007-08-23  Jakub Jelinek  <jakub@redhat.com>
 
 	* decl.c (variable_decl): Don't share charlen structs if

gcc/fortran/trans-array.c

@@ -4712,7 +4712,10 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
       tmp = gfc_conv_descriptor_dtype (parm);
       gfc_add_modify_expr (&loop.pre, tmp, gfc_get_dtype (parmtype));
 
-      if (se->direct_byref)
+      /* Set offset for assignments to pointer only to zero if it is not
+         the full array.  */
+      if (se->direct_byref
+	  && info->ref && info->ref->u.ar.type != AR_FULL)
 	base = gfc_index_zero_node;
       else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
 	base = gfc_evaluate_now (gfc_conv_array_offset (desc), &loop.pre);
@@ -4763,12 +4766,11 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 	  from = loop.from[dim];
 	  to = loop.to[dim];
 
-	  /* If we have an array section or are assigning to a pointer,
-	     make sure that the lower bound is 1.  References to the full
+	  /* If we have an array section or are assigning make sure that
+	     the lower bound is 1.  References to the full
 	     array should otherwise keep the original bounds.  */
 	  if ((!info->ref
-	       || info->ref->u.ar.type != AR_FULL
-	       || se->direct_byref)
+	          || info->ref->u.ar.type != AR_FULL)
 	      && !integer_onep (from))
 	    {
 	      tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
@@ -4788,7 +4790,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
 	  stride = fold_build2 (MULT_EXPR, gfc_array_index_type,
 				stride, info->stride[dim]);
 
-	  if (se->direct_byref)
+	  if (se->direct_byref && info->ref && info->ref->u.ar.type != AR_FULL)
 	    {
 	      base = fold_build2 (MINUS_EXPR, TREE_TYPE (base),
 				  base, stride);

gcc/testsuite/ChangeLog

+2007-08-24  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/33139
+	* gfortran.dg/pointer_assign_4.f90: New.
+	* gfortran.dg/shape_2.f90: Fix test case.
+	* gfortran.dg/char_result_4.f90: Ditto.
+
 2007-08-24  Jakub Jelinek  <jakub@redhat.com>
 
 	* gcc.dg/array-init-1.c: New test.

gcc/testsuite/gfortran.dg/char_result_4.f90

@@ -22,12 +22,12 @@ program main
 
   a = (/ (i + 5, i = 0, 4) /)
   ap => a
-  lower = 1
+  lower = lbound(a,dim=1)
 
   call test (f1 (ap), 35)
   call test (f2 (ap), 115)
   call test (f3 (ap), 60)
-  call test (f4 (ap, 5, 2), 21)
+  call test (f4 (ap, 104, 2), 21)
 contains
   function f1 (array)
     integer, dimension (:), pointer :: array
@@ -37,13 +37,13 @@ contains
 
   function f2 (array)
     integer, dimension (:), pointer :: array
-    character (len = array (2) + a (104) + 100) :: f2
+    character (len = array (101) + a (104) + 100) :: f2
     f2 = ''
   end function f2
 
   function f3 (array)
     integer, dimension (:), pointer :: array
-    character (len = sum (double (array (2:)))) :: f3
+    character (len = sum (double (array (101:)))) :: f3
     f3 = ''
   end function f3
 

gcc/testsuite/gfortran.dg/pointer_assign_4.f90

+! { dg-do run }
+!
+! Verify that the bounds are correctly set when assigning pointers.
+!
+! PR fortran/33139
+!
+program prog
+  implicit none
+  real, target :: a(-10:10)
+  real, pointer :: p(:),p2(:)
+  integer :: i
+  do i = -10, 10
+    a(i) = real(i)
+  end do
+  p  => a
+  p2 => p
+  if((lbound(p, dim=1) /= -10) .or. (ubound(p, dim=1) /= 10)) &
+    call abort()
+  if((lbound(p2,dim=1) /= -10) .or. (ubound(p2,dim=1) /= 10)) &
+    call abort()
+  do i = -10, 10
+    if(p(i) /= real(i)) call abort()
+    if(p2(i) /= real(i)) call abort()
+  end do
+  p => a(:)
+  p2 => p
+  if((lbound(p, dim=1) /= 1) .or. (ubound(p, dim=1) /= 21)) &
+    call abort()
+  if((lbound(p2,dim=1) /= 1) .or. (ubound(p2,dim=1) /= 21)) &
+    call abort()
+  p2 => p(:)
+  if((lbound(p2,dim=1) /= 1) .or. (ubound(p2,dim=1) /= 21)) &
+    call abort()
+  call multdim()
+contains
+  subroutine multdim()
+    real, target, allocatable :: b(:,:,:)
+    real, pointer :: ptr(:,:,:)
+    integer :: i, j, k
+    allocate(b(-5:5,10:20,0:3))
+    do i = 0, 3
+      do j = 10, 20
+        do k = -5, 5
+          b(k,j,i) = real(i+10*j+100*k)
+        end do
+      end do
+    end do
+    ptr => b
+    if((lbound(ptr,dim=1) /= -5) .or. (ubound(ptr,dim=1) /=  5) .or. &
+       (lbound(ptr,dim=2) /= 10) .or. (ubound(ptr,dim=2) /= 20) .or. &
+       (lbound(ptr,dim=3) /=  0) .or. (ubound(ptr,dim=3) /=  3))     &
+      call abort()
+    do i = 0, 3
+      do j = 10, 20
+        do k = -5, 5
+          if(ptr(k,j,i) /= real(i+10*j+100*k)) call abort()
+        end do
+      end do
+    end do
+    ptr => b(:,:,:)
+    if((lbound(ptr,dim=1) /= 1) .or. (ubound(ptr,dim=1) /= 11) .or. &
+       (lbound(ptr,dim=2) /= 1) .or. (ubound(ptr,dim=2) /= 11) .or. &
+       (lbound(ptr,dim=3) /= 1) .or. (ubound(ptr,dim=3) /=  4))     &
+      call abort()
+  end subroutine multdim
+end program prog

gcc/testsuite/gfortran.dg/shape_2.f90

@@ -22,9 +22,9 @@ contains
     if (ubound (b (20:30:3, 40), 1) .ne. 4) call abort
 
     ptr => b
-    if (lbound (ptr, 1) .ne. 1) call abort
-    if (ubound (ptr, 1) .ne. 40) call abort
-    if (lbound (ptr, 2) .ne. 1) call abort
-    if (ubound (ptr, 2) .ne. 80) call abort
+    if (lbound (ptr, 1) .ne. 11) call abort
+    if (ubound (ptr, 1) .ne. 50) call abort
+    if (lbound (ptr, 2) .ne. -8) call abort
+    if (ubound (ptr, 2) .ne. 71) call abort
   end subroutine test
 end program main