diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index a72bc3ea4fd..f313736ffcb 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,14 @@ +2010-01-31 Paul Thomas + + 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-25 Tobias Burnus PR fortran/42858 diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index d846c0f121e..6d3ca8476b8 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3489,6 +3489,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 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index dd86c1554b0..5b8f9c104e5 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2616,6 +2616,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); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index bb69d454e92..95ae8138867 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4045,6 +4045,149 @@ 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.u.derived->attr.alloc_comp) + tmp = gfc_copy_alloc_comp (cm->ts.u.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_get (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; + + /* 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_get (tmp, + gfc_rank_cst[n]); + } + else if (as) + lbound = gfc_conv_descriptor_lbound_get (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_get (dest, gfc_rank_cst[n]); + span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp, + gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n])); + tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, span, lbound); + gfc_conv_descriptor_ubound_set (&block, dest, + gfc_rank_cst[n], tmp); + gfc_conv_descriptor_lbound_set (&block, dest, + gfc_rank_cst[n], lbound); + + tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, + gfc_conv_descriptor_lbound_get (dest, + gfc_rank_cst[n]), + gfc_conv_descriptor_stride_get (dest, + gfc_rank_cst[n])); + gfc_add_modify (&block, tmp2, tmp); + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2); + gfc_conv_descriptor_offset_set (&block, dest, 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 @@ -4055,8 +4198,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); @@ -4103,89 +4244,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); - gfc_add_modify (&block, dest, se.expr); - - if (cm->ts.type == BT_DERIVED && cm->ts.u.derived->attr.alloc_comp) - tmp = gfc_copy_alloc_comp (cm->ts.u.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_get (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_get (dest, gfc_rank_cst[n]); - span = fold_build2 (MINUS_EXPR, gfc_array_index_type, tmp, - gfc_conv_descriptor_lbound_get (dest, gfc_rank_cst[n])); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - span, gfc_index_one_node); - gfc_conv_descriptor_ubound_set (&block, dest, gfc_rank_cst[n], - tmp); - gfc_conv_descriptor_lbound_set (&block, dest, gfc_rank_cst[n], - gfc_index_one_node); - } - tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, - gfc_conv_descriptor_lbound_get (dest, - gfc_rank_cst[n]), - gfc_conv_descriptor_stride_get (dest, - gfc_rank_cst[n])); - gfc_add_modify (&block, tmp2, tmp); - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, offset, tmp2); - gfc_conv_descriptor_offset_set (&block, dest, 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 { diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 208a3b5a8d7..62bf146b64d 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -838,7 +838,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; @@ -907,42 +906,7 @@ gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) ubound = gfc_conv_descriptor_ubound_get (desc, bound); lbound = gfc_conv_descriptor_lbound_get (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 diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index fcbade84f2f..8257646e9a5 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2010-01-31 Paul Thomas + + 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 Paolo Bonzini * g++.dg/tree-ssa/inline-1.C: New. diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 index e024d8b790d..15cf7cf710f 100644 --- a/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 +++ b/gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_bounds_1.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_bounds_1.f90 new file mode 100644 index 00000000000..28ad177e5a9 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/alloc_comp_bounds_1.f90 @@ -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 +! + 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 +