OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/38324 (Wrong lbound given to allocatable components) 

2010-01-31  Paul Thomas  <pault@gcc.gnu.org>

        PR fortran/38324
	* expr.c (gfc_get_full_arrayspec_from_expr): New function.
	* gfortran.h : Add prototype for above.
        * trans-expr.c (gfc_trans_alloc_subarray_assign): New function.
	(gfc_trans_subcomponent_assign): Call new function to replace
	the code to deal with allocatable components.
	* trans-intrinsic.c (gfc_conv_intrinsic_bound): Call
	gfc_get_full_arrayspec_from_expr to replace existing code.

2010-01-31  Paul Thomas  <pault@gcc.gnu.org>

        PR fortran/38324
        * gfortran.dg/alloc_comp_basics_1.f90: Remove option -O2.
        * gfortran.dg/alloc_comp_bounds_1.f90: New test.

From-SVN: r156401
This commit is contained in:
Paul Thomas 2010-01-31 14:57:13 +00:00
parent ccfdaa06c3
commit c80d1f1506
8 changed files with 268 additions and 124 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
gcc/fortran/ChangeLog
View File

@ -1,3 +1,14 @@
2010-01-31 Paul Thomas <pault@gcc.gnu.org>
PR fortran/38324
* expr.c (gfc_get_full_arrayspec_from_expr): New function.
* gfortran.h : Add prototype for above.
* trans-expr.c (gfc_trans_alloc_subarray_assign): New function.
(gfc_trans_subcomponent_assign): Call new function to replace
the code to deal with allocatable components.
* trans-intrinsic.c (gfc_conv_intrinsic_bound): Call
gfc_get_full_arrayspec_from_expr to replace existing code.
2010-01-30 Paul Thomas <pault@gcc.gnu.org>
PR fortran/41044

52
gcc/fortran/expr.c
View File

@ -3347,6 +3347,58 @@ gfc_get_variable_expr (gfc_symtree *var)
}
/* Returns the array_spec of a full array expression. A NULL is
returned otherwise. */
gfc_array_spec *
gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
{
gfc_array_spec *as;
gfc_ref *ref;
if (expr->rank == 0)
return NULL;
/* Follow any component references. */
if (expr->expr_type == EXPR_VARIABLE
|| expr->expr_type == EXPR_CONSTANT)
{
as = expr->symtree->n.sym->as;
for (ref = 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;
}
break;
}
}
}
}
else
as = NULL;
return as;
}
/* General expression traversal function. */
bool

2
gcc/fortran/gfortran.h
View File

@ -2450,6 +2450,8 @@ gfc_try gfc_check_assign_symbol (gfc_symbol *, gfc_expr *);
gfc_expr *gfc_default_initializer (gfc_typespec *);
gfc_expr *gfc_get_variable_expr (gfc_symtree *);
gfc_array_spec *gfc_get_full_arrayspec_from_expr (gfc_expr *expr);
bool gfc_traverse_expr (gfc_expr *, gfc_symbol *,
bool (*)(gfc_expr *, gfc_symbol *, int*),
int);

231
gcc/fortran/trans-expr.c
View File

@ -3518,6 +3518,150 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr)
}
static tree
gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
gfc_expr * expr)
{
gfc_se se;
gfc_ss *rss;
stmtblock_t block;
tree offset;
int n;
tree tmp;
tree tmp2;
gfc_array_spec *as;
gfc_expr *arg = NULL;
gfc_start_block (&block);
gfc_init_se (&se, NULL);
/* Get the descriptor for the expressions. */
rss = gfc_walk_expr (expr);
se.want_pointer = 0;
gfc_conv_expr_descriptor (&se, expr, rss);
gfc_add_block_to_block (&block, &se.pre);
gfc_add_modify (&block, dest, se.expr);
/* Deal with arrays of derived types with allocatable components. */
if (cm->ts.type == BT_DERIVED
&& cm->ts.derived->attr.alloc_comp)
tmp = gfc_copy_alloc_comp (cm->ts.derived,
se.expr, dest,
cm->as->rank);
else
tmp = gfc_duplicate_allocatable (dest, se.expr,
TREE_TYPE(cm->backend_decl),
cm->as->rank);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &se.post);
if (expr->expr_type != EXPR_VARIABLE)
gfc_conv_descriptor_data_set (&block, se.expr,
null_pointer_node);
/* We need to know if the argument of a conversion function is a
variable, so that the correct lower bound can be used. */
if (expr->expr_type == EXPR_FUNCTION
&& expr->value.function.isym
&& expr->value.function.isym->conversion
&& expr->value.function.actual->expr
&& expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
arg = expr->value.function.actual->expr;
/* Obtain the array spec of full array references. */
if (arg)
as = gfc_get_full_arrayspec_from_expr (arg);
else
as = gfc_get_full_arrayspec_from_expr (expr);
/* Shift the lbound and ubound of temporaries to being unity,
rather than zero, based. Always calculate the offset. */
offset = gfc_conv_descriptor_offset (dest);
gfc_add_modify (&block, offset, gfc_index_zero_node);
tmp2 =gfc_create_var (gfc_array_index_type, NULL);
for (n = 0; n < expr->rank; n++)
{
tree span;
tree lbound;
tree ubound;
/* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
TODO It looks as if gfc_conv_expr_descriptor should return
the correct bounds and that the following should not be
necessary. This would simplify gfc_conv_intrinsic_bound
as well. */
if (as && as->lower[n])
{
gfc_se lbse;
gfc_init_se (&lbse, NULL);
gfc_conv_expr (&lbse, as->lower[n]);
gfc_add_block_to_block (&block, &lbse.pre);
lbound = gfc_evaluate_now (lbse.expr, &block);
}
else if (as && arg)
{
tmp = gfc_get_symbol_decl (arg->symtree->n.sym);
lbound = gfc_conv_descriptor_lbound (tmp, gfc_rank_cst[n]);
}
else if (as)
lbound = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
else
lbound = gfc_index_one_node;
lbound = fold_convert (gfc_array_index_type, lbound);
/* Shift the bounds and set the offset accordingly. */
tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]));
ubound = fold_build2 (PLUS_EXPR, gfc_array_index_type,
span, lbound);
gfc_add_modify (&block, tmp, ubound);
tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
gfc_add_modify (&block, tmp, lbound);
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]),
gfc_conv_descriptor_stride (dest, gfc_rank_cst[n]));
gfc_add_modify (&block, tmp2, tmp);
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
offset, tmp2);
gfc_add_modify (&block, offset, tmp);
}
if (arg)
{
/* If a conversion expression has a null data pointer
argument, nullify the allocatable component. */
tree non_null_expr;
tree null_expr;
if (arg->symtree->n.sym->attr.allocatable
|| arg->symtree->n.sym->attr.pointer)
{
non_null_expr = gfc_finish_block (&block);
gfc_start_block (&block);
gfc_conv_descriptor_data_set (&block, dest,
null_pointer_node);
null_expr = gfc_finish_block (&block);
tmp = gfc_conv_descriptor_data_get (arg->symtree->n.sym->backend_decl);
tmp = build2 (EQ_EXPR, boolean_type_node, tmp,
fold_convert (TREE_TYPE (tmp),
null_pointer_node));
return build3_v (COND_EXPR, tmp,
null_expr, non_null_expr);
}
}
return gfc_finish_block (&block);
}
/* Assign a single component of a derived type constructor. */
static tree
@ -3528,8 +3672,6 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
gfc_ss *rss;
stmtblock_t block;
tree tmp;
tree offset;
int n;
gfc_start_block (&block);
@ -3569,91 +3711,8 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
else if (cm->attr.allocatable)
{
tree tmp2;
gfc_init_se (&se, NULL);
rss = gfc_walk_expr (expr);
se.want_pointer = 0;
gfc_conv_expr_descriptor (&se, expr, rss);
gfc_add_block_to_block (&block, &se.pre);
tmp = fold_convert (TREE_TYPE (dest), se.expr);
gfc_add_modify (&block, dest, tmp);
if (cm->ts.type == BT_DERIVED && cm->ts.derived->attr.alloc_comp)
tmp = gfc_copy_alloc_comp (cm->ts.derived, se.expr, dest,
cm->as->rank);
else
tmp = gfc_duplicate_allocatable (dest, se.expr,
TREE_TYPE(cm->backend_decl),
cm->as->rank);
tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &se.post);
if (expr->expr_type != EXPR_VARIABLE)
gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
/* Shift the lbound and ubound of temporaries to being unity, rather
than zero, based. Calculate the offset for all cases. */
offset = gfc_conv_descriptor_offset (dest);
gfc_add_modify (&block, offset, gfc_index_zero_node);
tmp2 =gfc_create_var (gfc_array_index_type, NULL);
for (n = 0; n < expr->rank; n++)
{
if (expr->expr_type != EXPR_VARIABLE
&& expr->expr_type != EXPR_CONSTANT)
{
tree span;
tmp = gfc_conv_descriptor_ubound (dest, gfc_rank_cst[n]);
span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp,
gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]));
gfc_add_modify (&block, tmp,
fold_build2 (PLUS_EXPR,
gfc_array_index_type,
span, gfc_index_one_node));
tmp = gfc_conv_descriptor_lbound (dest, gfc_rank_cst[n]);
gfc_add_modify (&block, tmp, gfc_index_one_node);
}
tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
gfc_conv_descriptor_lbound (dest,
gfc_rank_cst[n]),
gfc_conv_descriptor_stride (dest,
gfc_rank_cst[n]));
gfc_add_modify (&block, tmp2, tmp);
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2);
gfc_add_modify (&block, offset, tmp);
}
if (expr->expr_type == EXPR_FUNCTION
&& expr->value.function.isym
&& expr->value.function.isym->conversion
&& expr->value.function.actual->expr
&& expr->value.function.actual->expr->expr_type
== EXPR_VARIABLE)
{
/* If a conversion expression has a null data pointer
argument, nullify the allocatable component. */
gfc_symbol *s;
tree non_null_expr;
tree null_expr;
s = expr->value.function.actual->expr->symtree->n.sym;
if (s->attr.allocatable || s->attr.pointer)
{
non_null_expr = gfc_finish_block (&block);
gfc_start_block (&block);
gfc_conv_descriptor_data_set (&block, dest,
null_pointer_node);
null_expr = gfc_finish_block (&block);
tmp = gfc_conv_descriptor_data_get (s->backend_decl);
tmp = build2 (EQ_EXPR, boolean_type_node, tmp,
fold_convert (TREE_TYPE (tmp),
null_pointer_node));
return build3_v (COND_EXPR, tmp, null_expr,
non_null_expr);
}
}
}
else
{

38
gcc/fortran/trans-intrinsic.c
View File

@ -832,7 +832,6 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
gfc_se argse;
gfc_ss *ss;
gfc_array_spec * as;
gfc_ref *ref;
arg = expr->value.function.actual;
arg2 = arg->next;
@ -901,42 +900,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
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;
}
break;
}
}
}
}
else
as = NULL;
as = gfc_get_full_arrayspec_from_expr (arg->expr);
/* 13.14.53: Result value for LBOUND

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
2010-01-31 Paul Thomas <pault@gcc.gnu.org>
PR fortran/38324
* gfortran.dg/alloc_comp_basics_1.f90: Remove option -O2.
* gfortran.dg/alloc_comp_bounds_1.f90: New test.
2010-01-30 Paul Thomas <pault@gcc.gnu.org>
PR fortran/41044

2
gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90
View File

@ -1,5 +1,5 @@
! { dg-do run }
! { dg-options "-O2 -fdump-tree-original" }
! { dg-options "-fdump-tree-original" }
!
! Check some basic functionality of allocatable components, including that they
! are nullified when created and automatically deallocated when

50
gcc/testsuite/gfortran.dg/alloc_comp_bounds_1.f90 Normal file
View File

@ -0,0 +1,50 @@
! { dg-do run }
! Test the fix for PR38324, in which the bounds were not set correctly for
! constructor assignments with allocatable components.
!
! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr>
!
integer, parameter :: ik4 = 4
integer, parameter :: ik8 = 8
integer, parameter :: from = -1, to = 2
call foo
call bar
contains
subroutine foo
type :: struct
integer(4), allocatable :: ib(:)
end type struct
integer(ik4), allocatable :: ia(:)
type(struct) :: x
allocate(ia(from:to))
if (any(lbound(ia) .ne. -1) .or. any(ubound(ia) .ne. 2)) call abort
if (any(lbound(ia(:)) .ne. 1) .or. any(ubound(ia(:)) .ne. 4)) call abort
if (any(lbound(ia(from:to)) .ne. 1) .or. any(ubound(ia(from:to)) .ne. 4)) call abort
x=struct(ia)
if (any(lbound(x%ib) .ne. -1) .or. any(ubound(x%ib) .ne. 2)) call abort
x=struct(ia(:))
if (any(lbound(x%ib) .ne. 1) .or. any(ubound(x%ib) .ne. 4)) call abort
x=struct(ia(from:to))
if (any(lbound(x%ib) .ne. 1) .or. any(ubound(x%ib) .ne. 4)) call abort
deallocate(ia)
end subroutine
subroutine bar
type :: struct
integer(4), allocatable :: ib(:)
end type struct
integer(ik8), allocatable :: ia(:)
type(struct) :: x
allocate(ia(from:to))
if (any(lbound(ia) .ne. -1) .or. any(ubound(ia) .ne. 2)) call abort
if (any(lbound(ia(:)) .ne. 1) .or. any(ubound(ia(:)) .ne. 4)) call abort
if (any(lbound(ia(from:to)) .ne. 1) .or. any(ubound(ia(from:to)) .ne. 4)) call abort
x=struct(ia)
if (any(lbound(x%ib) .ne. -1) .or. any(ubound(x%ib) .ne. 2)) call abort
x=struct(ia(:))
if (any(lbound(x%ib) .ne. 1) .or. any(ubound(x%ib) .ne. 4)) call abort
x=struct(ia(from:to))
if (any(lbound(x%ib) .ne. 1) .or. any(ubound(x%ib) .ne. 4)) call abort
deallocate(ia)
end subroutine
end