From a7d318ea7f7b816250f872bc0cb13b9cd8277cd9 Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Fri, 24 Aug 2007 17:00:59 +0200 Subject: [PATCH] re PR fortran/33139 (array pointer assignment gives incorrect dimensions) 2007-08-24 Tobias Burnus PR fortran/33139 * trans-array.c (gfc_conv_expr_descriptor): Copy bounds for whole-array pointer assignments. 2007-08-24 Tobias Burnus 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 | 6 ++ gcc/fortran/trans-array.c | 16 +++-- gcc/testsuite/ChangeLog | 7 ++ gcc/testsuite/gfortran.dg/char_result_4.f90 | 8 +-- .../gfortran.dg/pointer_assign_4.f90 | 66 +++++++++++++++++++ gcc/testsuite/gfortran.dg/shape_2.f90 | 8 +-- 6 files changed, 96 insertions(+), 15 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pointer_assign_4.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 80111f31551..67d779181c0 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,9 @@ +2007-08-24 Tobias Burnus + + PR fortran/33139 + * trans-array.c (gfc_conv_expr_descriptor): Copy bounds for + whole-array pointer assignments. + 2007-08-23 Jakub Jelinek * decl.c (variable_decl): Don't share charlen structs if diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index f6b4751fb7c..73a57e82c4c 100644 --- a/gcc/fortran/trans-array.c +++ b/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); @@ -4824,7 +4826,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) } if ((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) - && !se->data_not_needed) + && !se->data_not_needed) { /* Set the offset. */ tmp = gfc_conv_descriptor_offset (parm); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index f7092ecf2cb..a27c2ad411e 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2007-08-24 Tobias Burnus + + 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 * gcc.dg/array-init-1.c: New test. diff --git a/gcc/testsuite/gfortran.dg/char_result_4.f90 b/gcc/testsuite/gfortran.dg/char_result_4.f90 index 0224f43c0b4..5e4f58e188b 100644 --- a/gcc/testsuite/gfortran.dg/char_result_4.f90 +++ b/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 diff --git a/gcc/testsuite/gfortran.dg/pointer_assign_4.f90 b/gcc/testsuite/gfortran.dg/pointer_assign_4.f90 new file mode 100644 index 00000000000..faf7c776c59 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pointer_assign_4.f90 @@ -0,0 +1,66 @@ +! { 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 diff --git a/gcc/testsuite/gfortran.dg/shape_2.f90 b/gcc/testsuite/gfortran.dg/shape_2.f90 index a4bde98ba5f..057cb4c8558 100644 --- a/gcc/testsuite/gfortran.dg/shape_2.f90 +++ b/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