re PR fortran/29391 ([4.2/4.1 only] LBOUND and UBOUND are broken)
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. From-SVN: r117691
This commit is contained in:
Francois-Xavier Coudert
François-Xavier Coudert
parent
ec2061a9bf
commit
ac677cc889
|
|
@ -1,3 +1,9 @@
|
|||
2006-10-13 Francois-Xavier Coudert <coudert@clipper.ens.fr>
|
||||
|
||||
PR fortran/29391
|
||||
* trans-intrinsic.c (gfc_conv_intrinsic_bound): Generate correct
|
||||
code for LBOUND and UBOUND intrinsics.
|
||||
|
||||
2006-10-13 Francois-Xavier Coudert <coudert@clipper.ens.fr>
|
||||
|
||||
PR fortran/21435
|
||||
|
|
|
|||
|
|
@ -710,9 +710,13 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
|
|||
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,10 +777,111 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
|
|||
}
|
||||
}
|
||||
|
||||
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);
|
||||
|
|
|
|||
|
|
@ -1,3 +1,8 @@
|
|||
2006-10-13 Francois-Xavier Coudert <coudert@clipper.ens.fr>
|
||||
|
||||
PR fortran/29391
|
||||
* gfortran.dg/bound_2.f90: New test.
|
||||
|
||||
2006-10-13 Francois-Xavier Coudert <coudert@clipper.ens.fr>
|
||||
|
||||
* gfortran.dg/defined_operators_1.f90: Add cleanup-modules dg
|
||||
|
|
|
|||
|
|
@ -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
|
||||
Loading…
Reference in New Issue