git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

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 2012-08-02 19:48:50 +00:00
parent c0febbd3cd
commit e5a24119f2
5 changed files with 315 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/fortran/ChangeLog
View File

@ -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

48
gcc/fortran/trans-array.c
View File

@ -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 ();
}

6
gcc/testsuite/ChangeLog
View File

@ -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>

143
gcc/testsuite/gfortran.dg/assumed_rank_bounds_1.f90 Normal file
View File

@ -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

112
gcc/testsuite/gfortran.dg/assumed_rank_bounds_2.f90 Normal file
View File

@ -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