aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/ChangeLog6
-rw-r--r--gcc/fortran/trans-array.c48
-rw-r--r--gcc/testsuite/ChangeLog6
-rw-r--r--gcc/testsuite/gfortran.dg/assumed_rank_bounds_1.f90143
-rw-r--r--gcc/testsuite/gfortran.dg/assumed_rank_bounds_2.f90112
5 files changed, 315 insertions, 0 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index ce97f68..1672449 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,11 @@
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
chosen using the stride and lower bound criteria.
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index b799e24..187eab0 100644
--- 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 14659cd..4198578 100644
--- 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
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
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
+
generated by cgit v1.1 at 2025-04-29 06:12:30 +0000