mirror of git://gcc.gnu.org/git/gcc.git
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
This commit is contained in:
Mikael Morin
parent
c0febbd3cd
commit
e5a24119f2
|
|
@ -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>
|
2012-08-02 Mikael Morin <mikael@gcc.gnu.org>
|
||||||
|
|
||||||
* trans-array.c (set_loop_bounds): Allow non-array-section to be
|
* trans-array.c (set_loop_bounds): Allow non-array-section to be
|
||||||
|
|
|
||||||
|
|
@ -3808,6 +3808,40 @@ done:
|
||||||
/* Fall through to supply start and stride. */
|
/* Fall through to supply start and stride. */
|
||||||
case GFC_ISYM_LBOUND:
|
case GFC_ISYM_LBOUND:
|
||||||
case GFC_ISYM_UBOUND:
|
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_LCOBOUND:
|
||||||
case GFC_ISYM_UCOBOUND:
|
case GFC_ISYM_UCOBOUND:
|
||||||
case GFC_ISYM_THIS_IMAGE:
|
case GFC_ISYM_THIS_IMAGE:
|
||||||
|
|
@ -4526,6 +4560,20 @@ set_loop_bounds (gfc_loopinfo *loop)
|
||||||
gcc_assert (loop->to[n] == NULL_TREE);
|
gcc_assert (loop->to[n] == NULL_TREE);
|
||||||
break;
|
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:
|
default:
|
||||||
gcc_unreachable ();
|
gcc_unreachable ();
|
||||||
}
|
}
|
||||||
|
|
|
||||||
|
|
@ -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>
|
2012-08-02 Jason Merrill <jason@redhat.com>
|
||||||
Paolo Carlini <paolo.carlini@oracle.com>
|
Paolo Carlini <paolo.carlini@oracle.com>
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -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
|
||||||
|
|
||||||
|
|
@ -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
|
||||||
|
|
||||||
Loading…
Reference in New Issue