This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[gfortran,commited] Fix LBOUND and UBOUND intrinsics
- From: "François-Xavier Coudert" <fxcoudert at gmail dot com>
- To: "fortran at gcc dot gnu dot org" <fortran at gcc dot gnu dot org>, patch <gcc-patches at gcc dot gnu dot org>
- Date: Fri, 13 Oct 2006 14:25:24 +0200
- Subject: [gfortran,commited] Fix LBOUND and UBOUND intrinsics
- Domainkey-signature: a=rsa-sha1; q=dns; c=nofws; s=beta; d=gmail.com; h=received:message-id:date:from:to:subject:mime-version:content-type; b=H514yJ64yAHXDDotdoZ75ZxROQfzYJxnXeyiUvkWEHiXkAmR+pyTerymNf0W8mlvpqUErjq4mrUfIZUsj70r7rns+061wrMYuiipcGoB9dyjzmDnDGRwkm/8Ky/qkTfN5kSbVNH72kiFMCbr6XdVhvIgfYE4knVilDJKOq3YKM0=
Hi all,
I commited the attached patch to mainline (rev. 117691) so that
gfortran generates correct code for LBOUND and UBOUND intrinsics
(which were broken in a large number of cases, see PR29391).
It was OKed by Paul Thomas on IRC, and regtested on x86_64-linux. I
intend to backport the patch to the 4.1 branch in a week or so.
PR fortran/29391
* trans-intrinsic.c (gfc_conv_intrinsic_bound): Generate correct
code for LBOUND and UBOUND intrinsics.
* gfortran.dg/bound_2.f90: New test.
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c (revision 117683)
+++ gcc/fortran/trans-intrinsic.c (working copy)
@@ -710,9 +710,13 @@
tree type;
tree bound;
tree tmp;
- tree cond;
+ tree cond, cond1, cond2, cond3, size;
+ tree ubound;
+ tree lbound;
gfc_se argse;
gfc_ss *ss;
+ gfc_array_spec * as;
+ gfc_ref *ref;
int i;
arg = expr->value.function.actual;
@@ -773,11 +777,112 @@
}
}
- if (upper)
- se->expr = gfc_conv_descriptor_ubound(desc, bound);
+ ubound = gfc_conv_descriptor_ubound (desc, bound);
+ lbound = gfc_conv_descriptor_lbound (desc, bound);
+
+ /* Follow any component references. */
+ if (arg->expr->expr_type == EXPR_VARIABLE
+ || arg->expr->expr_type == EXPR_CONSTANT)
+ {
+ as = arg->expr->symtree->n.sym->as;
+ for (ref = arg->expr->ref; ref; ref = ref->next)
+ {
+ switch (ref->type)
+ {
+ case REF_COMPONENT:
+ as = ref->u.c.component->as;
+ continue;
+
+ case REF_SUBSTRING:
+ continue;
+
+ case REF_ARRAY:
+ {
+ switch (ref->u.ar.type)
+ {
+ case AR_ELEMENT:
+ case AR_SECTION:
+ case AR_UNKNOWN:
+ as = NULL;
+ continue;
+
+ case AR_FULL:
+ break;
+ }
+ }
+ }
+ }
+ }
else
- se->expr = gfc_conv_descriptor_lbound(desc, bound);
+ as = NULL;
+ /* 13.14.53: Result value for LBOUND
+
+ Case (i): For an array section or for an array expression other than a
+ whole array or array structure component, LBOUND(ARRAY, DIM)
+ has the value 1. For a whole array or array structure
+ component, LBOUND(ARRAY, DIM) has the value:
+ (a) equal to the lower bound for subscript DIM of ARRAY if
+ dimension DIM of ARRAY does not have extent zero
+ or if ARRAY is an assumed-size array of rank DIM,
+ or (b) 1 otherwise.
+
+ 13.14.113: Result value for UBOUND
+
+ Case (i): For an array section or for an array expression other than a
+ whole array or array structure component, UBOUND(ARRAY, DIM)
+ has the value equal to the number of elements in the given
+ dimension; otherwise, it has a value equal to the upper bound
+ for subscript DIM of ARRAY if dimension DIM of ARRAY does
+ not have size zero and has value zero if dimension DIM has
+ size zero. */
+
+ if (as)
+ {
+ tree stride = gfc_conv_descriptor_stride (desc, bound);
+ cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound);
+ cond2 = fold_build2 (LE_EXPR, boolean_type_node, ubound, lbound);
+ cond3 = fold_build2 (GT_EXPR, boolean_type_node, stride,
+ gfc_index_zero_node);
+
+ if (upper)
+ {
+ cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
+ cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond2);
+
+ se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
+ ubound, gfc_index_zero_node);
+ }
+ else
+ {
+ if (as->type == AS_ASSUMED_SIZE)
+ cond = fold_build2 (EQ_EXPR, boolean_type_node, bound,
+ build_int_cst (TREE_TYPE (bound),
+ arg->expr->rank));
+ else
+ cond = boolean_false_node;
+
+ cond1 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
+ cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond1, cond2);
+
+ cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1);
+
+ se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
+ lbound, gfc_index_one_node);
+ }
+ }
+ else
+ {
+ if (upper)
+ {
+ size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
+ se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
+ gfc_index_one_node);
+ }
+ else
+ se->expr = gfc_index_one_node;
+ }
+
type = gfc_typenode_for_spec (&expr->ts);
se->expr = convert (type, se->expr);
}
Index: gcc/testsuite/gfortran.dg/bound_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/bound_2.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/bound_2.f90 (revision 0)
@@ -0,0 +1,72 @@
+! { dg-do run }
+! PR fortran/29391
+! This file is here to check that LBOUND and UBOUND return correct values
+!
+! Contributed by Francois-Xavier Coudert (coudert@clipper.ens.fr)
+ implicit none
+ integer :: i(-1:1,-1:1) = 0
+ integer :: j(-1:2) = 0
+
+ if (any(lbound(i(-1:1,-1:1)) /= 1)) call abort
+ if (any(ubound(i(-1:1,-1:1)) /= 3)) call abort
+ if (any(lbound(i(:,:)) /= 1)) call abort
+ if (any(ubound(i(:,:)) /= 3)) call abort
+ if (any(lbound(i(0:,-1:)) /= 1)) call abort
+ if (any(ubound(i(0:,-1:)) /= [2,3])) call abort
+ if (any(lbound(i(:0,:0)) /= 1)) call abort
+ if (any(ubound(i(:0,:0)) /= 2)) call abort
+
+ if (any(lbound(transpose(i)) /= 1)) call abort
+ if (any(ubound(transpose(i)) /= 3)) call abort
+ if (any(lbound(reshape(i,[2,2])) /= 1)) call abort
+ if (any(ubound(reshape(i,[2,2])) /= 2)) call abort
+ if (any(lbound(cshift(i,-1)) /= 1)) call abort
+ if (any(ubound(cshift(i,-1)) /= 3)) call abort
+ if (any(lbound(eoshift(i,-1)) /= 1)) call abort
+ if (any(ubound(eoshift(i,-1)) /= 3)) call abort
+ if (any(lbound(spread(i,1,2)) /= 1)) call abort
+ if (any(ubound(spread(i,1,2)) /= [2,3,3])) call abort
+ if (any(lbound(maxloc(i)) /= 1)) call abort
+ if (any(ubound(maxloc(i)) /= 2)) call abort
+ if (any(lbound(minloc(i)) /= 1)) call abort
+ if (any(ubound(minloc(i)) /= 2)) call abort
+ if (any(lbound(maxval(i,2)) /= 1)) call abort
+ if (any(ubound(maxval(i,2)) /= 3)) call abort
+ if (any(lbound(minval(i,2)) /= 1)) call abort
+ if (any(ubound(minval(i,2)) /= 3)) call abort
+ if (any(lbound(any(i==1,2)) /= 1)) call abort
+ if (any(ubound(any(i==1,2)) /= 3)) call abort
+ if (any(lbound(count(i==1,2)) /= 1)) call abort
+ if (any(ubound(count(i==1,2)) /= 3)) call abort
+ if (any(lbound(merge(i,i,.true.)) /= 1)) call abort
+ if (any(ubound(merge(i,i,.true.)) /= 3)) call abort
+ if (any(lbound(lbound(i)) /= 1)) call abort
+ if (any(ubound(lbound(i)) /= 2)) call abort
+ if (any(lbound(ubound(i)) /= 1)) call abort
+ if (any(ubound(ubound(i)) /= 2)) call abort
+ if (any(lbound(shape(i)) /= 1)) call abort
+ if (any(ubound(shape(i)) /= 2)) call abort
+
+ if (any(lbound(product(i,2)) /= 1)) call abort
+ if (any(ubound(product(i,2)) /= 3)) call abort
+ if (any(lbound(sum(i,2)) /= 1)) call abort
+ if (any(ubound(sum(i,2)) /= 3)) call abort
+ if (any(lbound(matmul(i,i)) /= 1)) call abort
+ if (any(ubound(matmul(i,i)) /= 3)) call abort
+ if (any(lbound(pack(i,.true.)) /= 1)) call abort
+ if (any(ubound(pack(i,.true.)) /= 9)) call abort
+ if (any(lbound(unpack(j,[.true.],[2])) /= 1)) call abort
+ if (any(ubound(unpack(j,[.true.],[2])) /= 1)) call abort
+
+ call sub1(i,3)
+ call sub1(reshape([7,9,4,6,7,9],[3,2]),3)
+
+contains
+
+ subroutine sub1(a,n)
+ integer :: a(2:n+1,4:*), n
+ if (any([lbound(a,1), lbound(a,2)] /= [2, 4])) call abort
+ if (any(lbound(a) /= [2, 4])) call abort
+ end subroutine sub1
+
+end