re PR fortran/48820 (TR 29113: Implement parts needed for MPI 3)

fortran/
	PR fortran/48820
	* trans-array.c (gfc_conv_ss_startstride): Set the intrinsic
	result's lower and upper bounds according to the rank.
	(set_loop_bounds): Set the loop upper bound in the intrinsic case.

testsuite/
	PR fortran/48820
	* gfortran.dg/assumed_rank_bounds_1.f90:  New test.
	* gfortran.dg/assumed_rank_bounds_2.f90:  New test.

From-SVN: r190098

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index ce97f6864ae2a3d59b7781cf6b8eee951b041140..167244977242a80368203a8aea23de366b920d5d 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2012-08-02  Mikael Morin  <mikael@gcc.gnu.org>
+
+       * trans-array.c (gfc_conv_ss_startstride): Set the intrinsic
+       result's lower and upper bounds according to the rank.
+       (set_loop_bounds): Set the loop upper bound in the intrinsic case.
+
 2012-08-02  Mikael Morin  <mikael@gcc.gnu.org>
 
        * trans-array.c (set_loop_bounds): Allow non-array-section to be

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index b799e2411636baf85409a723f2f550b9affe10f2..187eab01b008171a3ed62e2e819cca963438a488 100644 (file)
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -3808,6 +3808,40 @@ done:
            /* Fall through to supply start and stride.  */
            case GFC_ISYM_LBOUND:
            case GFC_ISYM_UBOUND:
+             {
+               gfc_expr *arg;
+
+               /* This is the variant without DIM=...  */
+               gcc_assert (expr->value.function.actual->next->expr == NULL);
+
+               arg = expr->value.function.actual->expr;
+               if (arg->rank == -1)
+                 {
+                   gfc_se se;
+                   tree rank, tmp;
+
+                   /* The rank (hence the return value's shape) is unknown,
+                      we have to retrieve it.  */
+                   gfc_init_se (&se, NULL);
+                   se.descriptor_only = 1;
+                   gfc_conv_expr (&se, arg);
+                   /* This is a bare variable, so there is no preliminary
+                      or cleanup code.  */
+                   gcc_assert (se.pre.head == NULL_TREE
+                               && se.post.head == NULL_TREE);
+                   rank = gfc_conv_descriptor_rank (se.expr);
+                   tmp = fold_build2_loc (input_location, MINUS_EXPR,
+                                          gfc_array_index_type,
+                                          fold_convert (gfc_array_index_type,
+                                                        rank),
+                                          gfc_index_one_node);
+                   info->end[0] = gfc_evaluate_now (tmp, &loop->pre);
+                   info->start[0] = gfc_index_zero_node;
+                   info->stride[0] = gfc_index_one_node;
+                   continue;
+                 }
+                 /* Otherwise fall through GFC_SS_FUNCTION.  */
+             }
            case GFC_ISYM_LCOBOUND:
            case GFC_ISYM_UCOBOUND:
            case GFC_ISYM_THIS_IMAGE:
@@ -4526,6 +4560,20 @@ set_loop_bounds (gfc_loopinfo *loop)
              gcc_assert (loop->to[n] == NULL_TREE);
              break;
 
+           case GFC_SS_INTRINSIC:
+             {
+               gfc_expr *expr = loopspec[n]->info->expr;
+
+               /* The {l,u}bound of an assumed rank.  */
+               gcc_assert ((expr->value.function.isym->id == GFC_ISYM_LBOUND
+                            || expr->value.function.isym->id == GFC_ISYM_UBOUND)
+                            && expr->value.function.actual->next->expr == NULL
+                            && expr->value.function.actual->expr->rank == -1);
+
+               loop->to[n] = info->end[dim];
+               break;
+             }
+
            default:
              gcc_unreachable ();
            }

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 14659cd123e46809e6d5fdb5a553c76113ae4aa1..4198578994cb20106bd487de0ef3142f6d3c880f 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2012-08-02  Mikael Morin  <mikael@gcc.gnu.org>
+
+       PR fortran/48820
+       * gfortran.dg/assumed_rank_bounds_1.f90:  New test.
+       * gfortran.dg/assumed_rank_bounds_2.f90:  New test.
+
 2012-08-02  Jason Merrill  <jason@redhat.com>
            Paolo Carlini  <paolo.carlini@oracle.com>
 

diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_bounds_1.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_bounds_1.f90
new file mode 100644 (file)
index 0000000..11d15f6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_bounds_1.f90
@@ -0,0 +1,143 @@
+! { dg-do run }
+!
+! Test the behaviour of lbound, ubound of shape with assumed rank arguments
+! in an array context (without DIM argument).
+!
+
+program test
+
+  integer              :: a(2:4,-2:5)
+  integer, allocatable :: b(:,:)
+  integer, pointer     :: c(:,:)
+  character(52)        :: buffer
+
+  call foo(a)
+
+  allocate(b(2:4,-2:5))
+  call foo(b)
+  call bar(b)
+
+  allocate(c(2:4,-2:5))
+  call foo(c)
+  call baz(c)
+
+contains
+  subroutine foo(arg)
+    integer :: arg(..)
+
+    !print *, lbound(arg)
+    !print *, id(lbound(arg))
+    if (any(lbound(arg) /= [1, 1])) call abort
+    if (any(id(lbound(arg)) /= [1, 1])) call abort
+    buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
+    write(buffer,*) lbound(arg)
+    if (buffer /= '           1           1') call abort
+    buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
+    write(buffer,*) id(lbound(arg))
+    if (buffer /= '           1           1') call abort
+
+    !print *, ubound(arg)
+    !print *, id(ubound(arg))
+    if (any(ubound(arg) /= [3, 8])) call abort
+    if (any(id(ubound(arg)) /= [3, 8])) call abort
+    buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
+    write(buffer,*) ubound(arg)
+    if (buffer /= '           3           8') call abort
+    buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
+    write(buffer,*) id(ubound(arg))
+    if (buffer /= '           3           8') call abort
+
+    !print *, shape(arg)
+    !print *, id(shape(arg))
+    if (any(shape(arg) /= [3, 8])) call abort
+    if (any(id(shape(arg)) /= [3, 8])) call abort
+    buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
+    write(buffer,*) shape(arg)
+    if (buffer /= '           3           8') call abort
+    buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
+    write(buffer,*) id(shape(arg))
+    if (buffer /= '           3           8') call abort
+
+  end subroutine foo
+  subroutine bar(arg)
+    integer, allocatable :: arg(:,:)
+
+    !print *, lbound(arg)
+    !print *, id(lbound(arg))
+    if (any(lbound(arg) /= [2, -2])) call abort
+    if (any(id(lbound(arg)) /= [2, -2])) call abort
+    buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
+    write(buffer,*) lbound(arg)
+    if (buffer /= '           2          -2') call abort
+    buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
+    write(buffer,*) id(lbound(arg))
+    if (buffer /= '           2          -2') call abort
+
+    !print *, ubound(arg)
+    !print *, id(ubound(arg))
+    if (any(ubound(arg) /= [4, 5])) call abort
+    if (any(id(ubound(arg)) /= [4, 5])) call abort
+    buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
+    write(buffer,*) ubound(arg)
+    if (buffer /= '           4           5') call abort
+    buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
+    write(buffer,*) id(ubound(arg))
+    if (buffer /= '           4           5') call abort
+
+    !print *, shape(arg)
+    !print *, id(shape(arg))
+    if (any(shape(arg) /= [3, 8])) call abort
+    if (any(id(shape(arg)) /= [3, 8])) call abort
+    buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
+    write(buffer,*) shape(arg)
+    if (buffer /= '           3           8') call abort
+    buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
+    write(buffer,*) id(shape(arg))
+    if (buffer /= '           3           8') call abort
+
+  end subroutine bar
+  subroutine baz(arg)
+    integer, pointer :: arg(..)
+
+    !print *, lbound(arg)
+    !print *, id(lbound(arg))
+    if (any(lbound(arg) /= [2, -2])) call abort
+    if (any(id(lbound(arg)) /= [2, -2])) call abort
+    buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
+    write(buffer,*) lbound(arg)
+    if (buffer /= '           2          -2') call abort
+    buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
+    write(buffer,*) id(lbound(arg))
+    if (buffer /= '           2          -2') call abort
+
+    !print *, ubound(arg)
+    !print *, id(ubound(arg))
+    if (any(ubound(arg) /= [4, 5])) call abort
+    if (any(id(ubound(arg)) /= [4, 5])) call abort
+    buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
+    write(buffer,*) ubound(arg)
+    if (buffer /= '           4           5') call abort
+    buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
+    write(buffer,*) id(ubound(arg))
+    if (buffer /= '           4           5') call abort
+
+    !print *, shape(arg)
+    !print *, id(shape(arg))
+    if (any(shape(arg) /= [3, 8])) call abort
+    if (any(id(shape(arg)) /= [3, 8])) call abort
+    buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
+    write(buffer,*) shape(arg)
+    if (buffer /= '           3           8') call abort
+    buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
+    write(buffer,*) id(shape(arg))
+    if (buffer /= '           3           8') call abort
+
+  end subroutine baz
+  elemental function id(arg)
+    integer, intent(in) :: arg
+    integer             :: id
+
+    id = arg
+  end function id
+end program test
+

diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_bounds_2.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_bounds_2.f90
new file mode 100644 (file)
index 0000000..b9c8e56
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_bounds_2.f90
@@ -0,0 +1,112 @@
+! { dg-do run }
+!
+! Test the behaviour of lbound, ubound of shape with assumed rank arguments
+! in an array context (without DIM argument).
+!
+
+program test
+
+  integer              :: a(2:4,-2:5)
+  integer, allocatable :: b(:,:)
+  integer, allocatable :: c(:,:)
+  integer, pointer     :: d(:,:)
+  character(52)        :: buffer
+
+  b = foo(a)
+  !print *,b(:,1)
+  if (any(b(:,1) /= [11, 101])) call abort
+  buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
+  write(buffer,*) b(:,1)
+  if (buffer /= '          11         101') call abort
+
+  !print *,b(:,2)
+  if (any(b(:,2) /= [3, 8])) call abort
+  buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
+  write(buffer,*) b(:,2)
+  if (buffer /= '           3           8') call abort
+
+  !print *,b(:,3)
+  if (any(b(:,3) /= [13, 108])) call abort
+  buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
+  write(buffer,*) b(:,3)
+  if (buffer /= '          13         108') call abort
+
+
+  allocate(c(1:2,-3:6))
+  b = bar(c)
+  !print *,b(:,1)
+  if (any(b(:,1) /= [11, 97])) call abort
+  buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
+  write(buffer,*) b(:,1)
+  if (buffer /= '          11          97') call abort
+
+  !print *,b(:,2)
+  if (any(b(:,2) /= [12, 106])) call abort
+  buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
+  write(buffer,*) b(:,2)
+  if (buffer /= '          12         106') call abort
+
+  !print *,b(:,3)
+  if (any(b(:,3) /= [2, 10])) call abort
+  buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
+  write(buffer,*) b(:,3)
+  if (buffer /= '           2          10') call abort
+
+
+  allocate(d(3:5,-1:10))
+  b = baz(d)
+  !print *,b(:,1)
+  if (any(b(:,1) /= [3, -1])) call abort
+  buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
+  write(buffer,*) b(:,1)
+  if (buffer /= '           3          -1') call abort
+
+  !print *,b(:,2)
+  if (any(b(:,2) /= [15, 110])) call abort
+  buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
+  write(buffer,*) b(:,2)
+  if (buffer /= '          15         110') call abort
+
+  !print *,b(:,3)
+  if (any(b(:,3) /= [13, 112])) call abort
+  buffer = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'
+  write(buffer,*) b(:,3)
+  if (buffer /= '          13         112') call abort
+
+
+contains
+  function foo(arg) result(res)
+    integer :: arg(..)
+    integer, allocatable :: res(:,:)
+
+    allocate(res(rank(arg), 3))
+
+    res(:,1) = lbound(arg) + (/ 10, 100 /)
+    res(:,2) = ubound(arg)
+    res(:,3) = (/ 10, 100 /) + shape(arg)
+
+  end function foo
+  function bar(arg) result(res)
+    integer, allocatable :: arg(..)
+    integer, allocatable :: res(:,:)
+
+    allocate(res(-1:rank(arg)-2, 3))
+
+    res(:,1) = lbound(arg) + (/ 10, 100 /)
+    res(:,2) = (/ 10, 100 /) + ubound(arg)
+    res(:,3) = shape(arg)
+
+  end function bar
+  function baz(arg) result(res)
+    integer, pointer     :: arg(..)
+    integer, allocatable :: res(:,:)
+
+    allocate(res(2:rank(arg)+1, 3))
+
+    res(:,1) = lbound(arg)
+    res(:,2) = (/ 10, 100 /) + ubound(arg)
+    res(:,3) = shape(arg) + (/ 10, 100 /)
+
+  end function baz
+end program test
+