diff options
Diffstat (limited to 'gcc/fortran/trans-array.c')
| -rw-r--r-- | gcc/fortran/trans-array.c | 631 |
1 files changed, 303 insertions, 328 deletions
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 7eb8e755785..cca4ecc4d9c 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -80,7 +80,7 @@ along with GCC; see the file COPYING3. If not see #include "system.h" #include "coretypes.h" #include "tree.h" -#include "toplev.h" /* For internal_error/fatal_error. */ +#include "diagnostic-core.h" /* For internal_error/fatal_error. */ #include "flags.h" #include "gfortran.h" #include "constructor.h" @@ -434,10 +434,10 @@ gfc_free_ss (gfc_ss * ss) switch (ss->type) { case GFC_SS_SECTION: - for (n = 0; n < GFC_MAX_DIMENSIONS; n++) + for (n = 0; n < ss->data.info.dimen; n++) { - if (ss->data.info.subscript[n]) - gfc_free_ss_chain (ss->data.info.subscript[n]); + if (ss->data.info.subscript[ss->data.info.dim[n]]) + gfc_free_ss_chain (ss->data.info.subscript[ss->data.info.dim[n]]); } break; @@ -762,25 +762,28 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, for (n = 0; n < info->dimen; n++) { + dim = info->dim[n]; + if (size == NULL_TREE) { /* For a callee allocated array express the loop bounds in terms of the descriptor fields. */ - tmp = - fold_build2 (MINUS_EXPR, gfc_array_index_type, - gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]), - gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n])); + tmp = fold_build2 ( + MINUS_EXPR, gfc_array_index_type, + gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]), + gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim])); loop->to[n] = tmp; continue; } /* Store the stride and bound components in the descriptor. */ - gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[n], size); + gfc_conv_descriptor_stride_set (pre, desc, gfc_rank_cst[dim], size); - gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n], + gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[dim], gfc_index_zero_node); - gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], loop->to[n]); + gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[dim], + loop->to[n]); tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, loop->to[n], gfc_index_one_node); @@ -2177,9 +2180,12 @@ gfc_init_loopinfo (gfc_loopinfo * loop) gfc_init_block (&loop->pre); gfc_init_block (&loop->post); - /* Initially scalarize in order. */ + /* Initially scalarize in order and default to no loop reversal. */ for (n = 0; n < GFC_MAX_DIMENSIONS; n++) - loop->order[n] = n; + { + loop->order[n] = n; + loop->reverse[n] = GFC_CANNOT_REVERSE; + } loop->ss = gfc_ss_terminator; } @@ -2387,7 +2393,8 @@ gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n, /* Return the offset for an index. Performs bound checking for elemental - dimensions. Single element references are processed separately. */ + dimensions. Single element references are processed separately. + DIM is the array dimension, I is the loop dimension. */ static tree gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i, @@ -2448,14 +2455,14 @@ gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i, /* Scalarized dimension. */ gcc_assert (info && se->loop); - /* Multiply the loop variable by the stride and delta. */ + /* Multiply the loop variable by the stride and delta. */ index = se->loop->loopvar[i]; - if (!integer_onep (info->stride[i])) + if (!integer_onep (info->stride[dim])) index = fold_build2 (MULT_EXPR, gfc_array_index_type, index, - info->stride[i]); - if (!integer_zerop (info->delta[i])) + info->stride[dim]); + if (!integer_zerop (info->delta[dim])) index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, - info->delta[i]); + info->delta[dim]); break; default: @@ -2467,9 +2474,9 @@ gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i, /* Temporary array or derived type component. */ gcc_assert (se->loop); index = se->loop->loopvar[se->loop->order[i]]; - if (!integer_zerop (info->delta[i])) + if (!integer_zerop (info->delta[dim])) index = fold_build2 (PLUS_EXPR, gfc_array_index_type, - index, info->delta[i]); + index, info->delta[dim]); } /* Multiply by the stride. */ @@ -2838,8 +2845,18 @@ gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n, } else { + bool reverse_loop = (loop->reverse[n] == GFC_REVERSE_SET) + && (loop->temp_ss == NULL); + loopbody = gfc_finish_block (pbody); + if (reverse_loop) + { + tmp = loop->from[n]; + loop->from[n] = loop->to[n]; + loop->to[n] = tmp; + } + /* Initialize the loopvar. */ if (loop->loopvar[n] != loop->from[n]) gfc_add_modify (&loop->code[n], loop->loopvar[n], loop->from[n]); @@ -2850,8 +2867,8 @@ gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n, gfc_init_block (&block); /* The exit condition. */ - cond = fold_build2 (GT_EXPR, boolean_type_node, - loop->loopvar[n], loop->to[n]); + cond = fold_build2 (reverse_loop ? LT_EXPR : GT_EXPR, + boolean_type_node, loop->loopvar[n], loop->to[n]); tmp = build1_v (GOTO_EXPR, exit_label); TREE_USED (exit_label) = 1; tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location)); @@ -2861,8 +2878,10 @@ gfc_trans_scalarized_loop_end (gfc_loopinfo * loop, int n, gfc_add_expr_to_block (&block, loopbody); /* Increment the loopvar. */ - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, - loop->loopvar[n], gfc_index_one_node); + tmp = fold_build2 (reverse_loop ? MINUS_EXPR : PLUS_EXPR, + gfc_array_index_type, loop->loopvar[n], + gfc_index_one_node); + gfc_add_modify (&block, loop->loopvar[n], tmp); /* Build the loop. */ @@ -2964,54 +2983,10 @@ gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body) } -/* Calculate the upper bound of an array section. */ - -static tree -gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock) -{ - int dim; - gfc_expr *end; - tree desc; - tree bound; - gfc_se se; - gfc_ss_info *info; - - gcc_assert (ss->type == GFC_SS_SECTION); - - info = &ss->data.info; - dim = info->dim[n]; - - if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR) - /* We'll calculate the upper bound once we have access to the - vector's descriptor. */ - return NULL; - - gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE); - desc = info->descriptor; - end = info->ref->u.ar.end[dim]; - - if (end) - { - /* The upper bound was specified. */ - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, end, gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - bound = se.expr; - } - else - { - /* No upper bound was specified, so use the bound of the array. */ - bound = gfc_conv_array_ubound (desc, dim); - } - - return bound; -} - - /* Calculate the lower bound of an array section. */ static void -gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n) +gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim) { gfc_expr *start; gfc_expr *end; @@ -3019,19 +2994,17 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n) tree desc; gfc_se se; gfc_ss_info *info; - int dim; gcc_assert (ss->type == GFC_SS_SECTION); info = &ss->data.info; - dim = info->dim[n]; if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR) { /* We use a zero-based index to access the vector. */ - info->start[n] = gfc_index_zero_node; - info->end[n] = gfc_index_zero_node; - info->stride[n] = gfc_index_one_node; + info->start[dim] = gfc_index_zero_node; + info->stride[dim] = gfc_index_one_node; + info->end[dim] = NULL; return; } @@ -3049,14 +3022,14 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n) gfc_init_se (&se, NULL); gfc_conv_expr_type (&se, start, gfc_array_index_type); gfc_add_block_to_block (&loop->pre, &se.pre); - info->start[n] = se.expr; + info->start[dim] = se.expr; } else { /* No lower bound specified so use the bound of the array. */ - info->start[n] = gfc_conv_array_lbound (desc, dim); + info->start[dim] = gfc_conv_array_lbound (desc, dim); } - info->start[n] = gfc_evaluate_now (info->start[n], &loop->pre); + info->start[dim] = gfc_evaluate_now (info->start[dim], &loop->pre); /* Similarly calculate the end. Although this is not used in the scalarizer, it is needed when checking bounds and where the end @@ -3067,24 +3040,24 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n) gfc_init_se (&se, NULL); gfc_conv_expr_type (&se, end, gfc_array_index_type); gfc_add_block_to_block (&loop->pre, &se.pre); - info->end[n] = se.expr; + info->end[dim] = se.expr; } else { /* No upper bound specified so use the bound of the array. */ - info->end[n] = gfc_conv_array_ubound (desc, dim); + info->end[dim] = gfc_conv_array_ubound (desc, dim); } - info->end[n] = gfc_evaluate_now (info->end[n], &loop->pre); + info->end[dim] = gfc_evaluate_now (info->end[dim], &loop->pre); /* Calculate the stride. */ if (stride == NULL) - info->stride[n] = gfc_index_one_node; + info->stride[dim] = gfc_index_one_node; else { gfc_init_se (&se, NULL); gfc_conv_expr_type (&se, stride, gfc_array_index_type); gfc_add_block_to_block (&loop->pre, &se.pre); - info->stride[n] = gfc_evaluate_now (se.expr, &loop->pre); + info->stride[dim] = gfc_evaluate_now (se.expr, &loop->pre); } } @@ -3149,7 +3122,7 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) gfc_conv_ss_descriptor (&loop->pre, ss, !loop->array_parameter); for (n = 0; n < ss->data.info.dimen; n++) - gfc_conv_section_startstride (loop, ss, n); + gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n]); break; case GFC_SS_INTRINSIC: @@ -3224,11 +3197,10 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) check_upper = true; /* Zero stride is not allowed. */ - tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[n], + tmp = fold_build2 (EQ_EXPR, boolean_type_node, info->stride[dim], gfc_index_zero_node); asprintf (&msg, "Zero stride is not allowed, for dimension %d " - "of array '%s'", info->dim[n]+1, - ss->expr->symtree->name); + "of array '%s'", dim + 1, ss->expr->symtree->name); gfc_trans_runtime_check (true, false, tmp, &inner, &ss->expr->where, msg); gfc_free (msg); @@ -3236,27 +3208,27 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) desc = ss->data.info.descriptor; /* This is the run-time equivalent of resolve.c's - check_dimension(). The logical is more readable there - than it is here, with all the trees. */ + check_dimension(). The logical is more readable there + than it is here, with all the trees. */ lbound = gfc_conv_array_lbound (desc, dim); - end = info->end[n]; + end = info->end[dim]; if (check_upper) ubound = gfc_conv_array_ubound (desc, dim); else ubound = NULL; /* non_zerosized is true when the selected range is not - empty. */ + empty. */ stride_pos = fold_build2 (GT_EXPR, boolean_type_node, - info->stride[n], gfc_index_zero_node); - tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[n], + info->stride[dim], gfc_index_zero_node); + tmp = fold_build2 (LE_EXPR, boolean_type_node, info->start[dim], end); stride_pos = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, stride_pos, tmp); stride_neg = fold_build2 (LT_EXPR, boolean_type_node, - info->stride[n], gfc_index_zero_node); - tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[n], + info->stride[dim], gfc_index_zero_node); + tmp = fold_build2 (GE_EXPR, boolean_type_node, info->start[dim], end); stride_neg = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, stride_neg, tmp); @@ -3269,41 +3241,41 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) error message. */ if (check_upper) { - tmp = fold_build2 (LT_EXPR, boolean_type_node, - info->start[n], lbound); + tmp = fold_build2 (LT_EXPR, boolean_type_node, + info->start[dim], lbound); tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, non_zerosized, tmp); tmp2 = fold_build2 (GT_EXPR, boolean_type_node, - info->start[n], ubound); + info->start[dim], ubound); tmp2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, non_zerosized, tmp2); asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " - "outside of expected range (%%ld:%%ld)", - info->dim[n]+1, ss->expr->symtree->name); - gfc_trans_runtime_check (true, false, tmp, &inner, + "outside of expected range (%%ld:%%ld)", + dim + 1, ss->expr->symtree->name); + gfc_trans_runtime_check (true, false, tmp, &inner, &ss->expr->where, msg, - fold_convert (long_integer_type_node, info->start[n]), - fold_convert (long_integer_type_node, lbound), + fold_convert (long_integer_type_node, info->start[dim]), + fold_convert (long_integer_type_node, lbound), fold_convert (long_integer_type_node, ubound)); - gfc_trans_runtime_check (true, false, tmp2, &inner, + gfc_trans_runtime_check (true, false, tmp2, &inner, &ss->expr->where, msg, - fold_convert (long_integer_type_node, info->start[n]), - fold_convert (long_integer_type_node, lbound), + fold_convert (long_integer_type_node, info->start[dim]), + fold_convert (long_integer_type_node, lbound), fold_convert (long_integer_type_node, ubound)); gfc_free (msg); } else { - tmp = fold_build2 (LT_EXPR, boolean_type_node, - info->start[n], lbound); + tmp = fold_build2 (LT_EXPR, boolean_type_node, + info->start[dim], lbound); tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, non_zerosized, tmp); asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " - "below lower bound of %%ld", - info->dim[n]+1, ss->expr->symtree->name); - gfc_trans_runtime_check (true, false, tmp, &inner, + "below lower bound of %%ld", + dim + 1, ss->expr->symtree->name); + gfc_trans_runtime_check (true, false, tmp, &inner, &ss->expr->where, msg, - fold_convert (long_integer_type_node, info->start[n]), + fold_convert (long_integer_type_node, info->start[dim]), fold_convert (long_integer_type_node, lbound)); gfc_free (msg); } @@ -3313,9 +3285,9 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) and check it against both lower and upper bounds. */ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end, - info->start[n]); + info->start[dim]); tmp = fold_build2 (TRUNC_MOD_EXPR, gfc_array_index_type, tmp, - info->stride[n]); + info->stride[dim]); tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end, tmp); tmp2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, lbound); @@ -3327,8 +3299,8 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) tmp3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, non_zerosized, tmp3); asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " - "outside of expected range (%%ld:%%ld)", - info->dim[n]+1, ss->expr->symtree->name); + "outside of expected range (%%ld:%%ld)", + dim + 1, ss->expr->symtree->name); gfc_trans_runtime_check (true, false, tmp2, &inner, &ss->expr->where, msg, fold_convert (long_integer_type_node, tmp), @@ -3344,32 +3316,32 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) else { asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " - "below lower bound of %%ld", - info->dim[n]+1, ss->expr->symtree->name); + "below lower bound of %%ld", + dim + 1, ss->expr->symtree->name); gfc_trans_runtime_check (true, false, tmp2, &inner, &ss->expr->where, msg, fold_convert (long_integer_type_node, tmp), fold_convert (long_integer_type_node, lbound)); gfc_free (msg); } - + /* Check the section sizes match. */ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, end, - info->start[n]); + info->start[dim]); tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, tmp, - info->stride[n]); + info->stride[dim]); tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, gfc_index_one_node, tmp); tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp, build_int_cst (gfc_array_index_type, 0)); /* We remember the size of the first section, and check all the - others against this. */ + others against this. */ if (size[n]) { tmp3 = fold_build2 (NE_EXPR, boolean_type_node, tmp, size[n]); asprintf (&msg, "Array bound mismatch for dimension %d " "of array '%s' (%%ld/%%ld)", - info->dim[n]+1, ss->expr->symtree->name); + dim + 1, ss->expr->symtree->name); gfc_trans_runtime_check (true, false, tmp3, &inner, &ss->expr->where, msg, @@ -3492,7 +3464,8 @@ gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest, lref = dest->expr->ref; rref = ss->expr->ref; - nDepend = gfc_dep_resolver (lref, rref); + nDepend = gfc_dep_resolver (lref, rref, &loop->reverse[0]); + if (nDepend == 1) break; #if 0 @@ -3561,7 +3534,7 @@ gfc_conv_resolve_dependencies (gfc_loopinfo * loop, gfc_ss * dest, void gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) { - int n; + int n, dim, spec_dim; gfc_ss_info *info; gfc_ss_info *specinfo; gfc_ss *ss; @@ -3577,14 +3550,34 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) loopspec[n] = NULL; dynamic[n] = false; /* We use one SS term, and use that to determine the bounds of the - loop for this dimension. We try to pick the simplest term. */ + loop for this dimension. We try to pick the simplest term. */ for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) { + if (ss->type == GFC_SS_SCALAR || ss->type == GFC_SS_REFERENCE) + continue; + + info = &ss->data.info; + dim = info->dim[n]; + + if (loopspec[n] != NULL) + { + specinfo = &loopspec[n]->data.info; + spec_dim = specinfo->dim[n]; + } + else + { + /* Silence unitialized warnings. */ + specinfo = NULL; + spec_dim = 0; + } + if (ss->shape) { + gcc_assert (ss->shape[dim]); /* The frontend has worked out the size for us. */ - if (!loopspec[n] || !loopspec[n]->shape - || !integer_zerop (loopspec[n]->data.info.start[n])) + if (!loopspec[n] + || !loopspec[n]->shape + || !integer_zerop (specinfo->start[spec_dim])) /* Prefer zero-based descriptors if possible. */ loopspec[n] = ss; continue; @@ -3611,22 +3604,16 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) /* TODO: Pick the best bound if we have a choice between a function and something else. */ - if (ss->type == GFC_SS_FUNCTION) - { - loopspec[n] = ss; - continue; - } + if (ss->type == GFC_SS_FUNCTION) + { + loopspec[n] = ss; + continue; + } if (ss->type != GFC_SS_SECTION) continue; - if (loopspec[n]) - specinfo = &loopspec[n]->data.info; - else - specinfo = NULL; - info = &ss->data.info; - - if (!specinfo) + if (!loopspec[n]) loopspec[n] = ss; /* Criteria for choosing a loop specifier (most important first): doesn't need realloc @@ -3637,14 +3624,14 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) */ else if (loopspec[n]->type == GFC_SS_CONSTRUCTOR && dynamic[n]) loopspec[n] = ss; - else if (integer_onep (info->stride[n]) - && !integer_onep (specinfo->stride[n])) + else if (integer_onep (info->stride[dim]) + && !integer_onep (specinfo->stride[spec_dim])) loopspec[n] = ss; - else if (INTEGER_CST_P (info->stride[n]) - && !INTEGER_CST_P (specinfo->stride[n])) + else if (INTEGER_CST_P (info->stride[dim]) + && !INTEGER_CST_P (specinfo->stride[spec_dim])) loopspec[n] = ss; - else if (INTEGER_CST_P (info->start[n]) - && !INTEGER_CST_P (specinfo->start[n])) + else if (INTEGER_CST_P (info->start[dim]) + && !INTEGER_CST_P (specinfo->start[spec_dim])) loopspec[n] = ss; /* We don't work out the upper bound. else if (INTEGER_CST_P (info->finish[n]) @@ -3657,26 +3644,27 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) gcc_assert (loopspec[n]); info = &loopspec[n]->data.info; + dim = info->dim[n]; /* Set the extents of this range. */ cshape = loopspec[n]->shape; - if (cshape && INTEGER_CST_P (info->start[n]) - && INTEGER_CST_P (info->stride[n])) + if (cshape && INTEGER_CST_P (info->start[dim]) + && INTEGER_CST_P (info->stride[dim])) { - loop->from[n] = info->start[n]; + loop->from[n] = info->start[dim]; mpz_set (i, cshape[n]); mpz_sub_ui (i, i, 1); /* To = from + (size - 1) * stride. */ tmp = gfc_conv_mpz_to_tree (i, gfc_index_integer_kind); - if (!integer_onep (info->stride[n])) + if (!integer_onep (info->stride[dim])) tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, - tmp, info->stride[n]); + tmp, info->stride[dim]); loop->to[n] = fold_build2 (PLUS_EXPR, gfc_array_index_type, loop->from[n], tmp); } else { - loop->from[n] = info->start[n]; + loop->from[n] = info->start[dim]; switch (loopspec[n]->type) { case GFC_SS_CONSTRUCTOR: @@ -3688,17 +3676,13 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) case GFC_SS_SECTION: /* Use the end expression if it exists and is not constant, so that it is only evaluated once. */ - if (info->end[n] && !INTEGER_CST_P (info->end[n])) - loop->to[n] = info->end[n]; - else - loop->to[n] = gfc_conv_section_upper_bound (loopspec[n], n, - &loop->pre); + loop->to[n] = info->end[dim]; break; - case GFC_SS_FUNCTION: + case GFC_SS_FUNCTION: /* The loop bound will be set when we generate the call. */ - gcc_assert (loop->to[n] == NULL_TREE); - break; + gcc_assert (loop->to[n] == NULL_TREE); + break; default: gcc_unreachable (); @@ -3706,20 +3690,20 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) } /* Transform everything so we have a simple incrementing variable. */ - if (integer_onep (info->stride[n])) - info->delta[n] = gfc_index_zero_node; + if (integer_onep (info->stride[dim])) + info->delta[dim] = gfc_index_zero_node; else { /* Set the delta for this section. */ - info->delta[n] = gfc_evaluate_now (loop->from[n], &loop->pre); + info->delta[dim] = gfc_evaluate_now (loop->from[n], &loop->pre); /* Number of iterations is (end - start + step) / step. with start = 0, this simplifies to last = end / step; for (i = 0; i<=last; i++){...}; */ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, loop->to[n], loop->from[n]); - tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, - tmp, info->stride[n]); + tmp = fold_build2 (FLOOR_DIV_EXPR, gfc_array_index_type, + tmp, info->stride[dim]); tmp = fold_build2 (MAX_EXPR, gfc_array_index_type, tmp, build_int_cst (gfc_array_index_type, -1)); loop->to[n] = gfc_evaluate_now (tmp, &loop->pre); @@ -3780,18 +3764,20 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) /* If we are specifying the range the delta is already set. */ if (loopspec[n] != ss) { + dim = ss->data.info.dim[n]; + /* Calculate the offset relative to the loop variable. - First multiply by the stride. */ + First multiply by the stride. */ tmp = loop->from[n]; - if (!integer_onep (info->stride[n])) + if (!integer_onep (info->stride[dim])) tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, - tmp, info->stride[n]); + tmp, info->stride[dim]); /* Then subtract this from our starting value. */ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, - info->start[n], tmp); + info->start[dim], tmp); - info->delta[n] = gfc_evaluate_now (tmp, &loop->pre); + info->delta[dim] = gfc_evaluate_now (tmp, &loop->pre); } } } @@ -4313,10 +4299,11 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset, /* Generate code to initialize/allocate an array variable. */ -tree -gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody) +void +gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, + gfc_wrapped_block * block) { - stmtblock_t block; + stmtblock_t init; tree type; tree tmp; tree size; @@ -4327,32 +4314,32 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody) /* Do nothing for USEd variables. */ if (sym->attr.use_assoc) - return fnbody; + return; type = TREE_TYPE (decl); gcc_assert (GFC_ARRAY_TYPE_P (type)); onstack = TREE_CODE (type) != POINTER_TYPE; - gfc_start_block (&block); + gfc_start_block (&init); /* Evaluate character string length. */ if (sym->ts.type == BT_CHARACTER && onstack && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) { - gfc_conv_string_length (sym->ts.u.cl, NULL, &block); + gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - gfc_trans_vla_type_sizes (sym, &block); + gfc_trans_vla_type_sizes (sym, &init); /* Emit a DECL_EXPR for this variable, which will cause the gimplifier to allocate storage, and all that good stuff. */ tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl); - gfc_add_expr_to_block (&block, tmp); + gfc_add_expr_to_block (&init, tmp); } if (onstack) { - gfc_add_expr_to_block (&block, fnbody); - return gfc_finish_block (&block); + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); + return; } type = TREE_TYPE (type); @@ -4363,17 +4350,18 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody) if (sym->ts.type == BT_CHARACTER && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) - gfc_conv_string_length (sym->ts.u.cl, NULL, &block); + gfc_conv_string_length (sym->ts.u.cl, NULL, &init); - size = gfc_trans_array_bounds (type, sym, &offset, &block); + size = gfc_trans_array_bounds (type, sym, &offset, &init); /* Don't actually allocate space for Cray Pointees. */ if (sym->attr.cray_pointee) { if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL) - gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset); - gfc_add_expr_to_block (&block, fnbody); - return gfc_finish_block (&block); + gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); + + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); + return; } /* The size is the number of elements in the array, so multiply by the @@ -4383,31 +4371,27 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody) fold_convert (gfc_array_index_type, tmp)); /* Allocate memory to hold the data. */ - tmp = gfc_call_malloc (&block, TREE_TYPE (decl), size); - gfc_add_modify (&block, decl, tmp); + tmp = gfc_call_malloc (&init, TREE_TYPE (decl), size); + gfc_add_modify (&init, decl, tmp); /* Set offset of the array. */ if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL) - gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset); - + gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); /* Automatic arrays should not have initializers. */ gcc_assert (!sym->value); - gfc_add_expr_to_block (&block, fnbody); - /* Free the temporary. */ tmp = gfc_call_free (convert (pvoid_type_node, decl)); - gfc_add_expr_to_block (&block, tmp); - return gfc_finish_block (&block); + gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp); } /* Generate entry and exit code for g77 calling convention arrays. */ -tree -gfc_trans_g77_array (gfc_symbol * sym, tree body) +void +gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block) { tree parm; tree type; @@ -4415,7 +4399,7 @@ gfc_trans_g77_array (gfc_symbol * sym, tree body) tree offset; tree tmp; tree stmt; - stmtblock_t block; + stmtblock_t init; gfc_get_backend_locus (&loc); gfc_set_backend_locus (&sym->declared_at); @@ -4425,31 +4409,29 @@ gfc_trans_g77_array (gfc_symbol * sym, tree body) type = TREE_TYPE (parm); gcc_assert (GFC_ARRAY_TYPE_P (type)); - gfc_start_block (&block); + gfc_start_block (&init); if (sym->ts.type == BT_CHARACTER && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL) - gfc_conv_string_length (sym->ts.u.cl, NULL, &block); + gfc_conv_string_length (sym->ts.u.cl, NULL, &init); /* Evaluate the bounds of the array. */ - gfc_trans_array_bounds (type, sym, &offset, &block); + gfc_trans_array_bounds (type, sym, &offset, &init); /* Set the offset. */ if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL) - gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset); + gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); /* Set the pointer itself if we aren't using the parameter directly. */ if (TREE_CODE (parm) != PARM_DECL) { tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm)); - gfc_add_modify (&block, parm, tmp); + gfc_add_modify (&init, parm, tmp); } - stmt = gfc_finish_block (&block); + stmt = gfc_finish_block (&init); gfc_set_backend_locus (&loc); - gfc_start_block (&block); - /* Add the initialization code to the start of the function. */ if (sym->attr.optional || sym->attr.not_always_present) @@ -4458,10 +4440,7 @@ gfc_trans_g77_array (gfc_symbol * sym, tree body) stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location)); } - gfc_add_expr_to_block (&block, stmt); - gfc_add_expr_to_block (&block, body); - - return gfc_finish_block (&block); + gfc_add_init_cleanup (block, stmt, NULL_TREE); } @@ -4476,22 +4455,22 @@ gfc_trans_g77_array (gfc_symbol * sym, tree body) Code is also added to copy the data back at the end of the function. */ -tree -gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) +void +gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, + gfc_wrapped_block * block) { tree size; tree type; tree offset; locus loc; - stmtblock_t block; - stmtblock_t cleanup; + stmtblock_t init; + tree stmtInit, stmtCleanup; tree lbound; tree ubound; tree dubound; tree dlbound; tree dumdesc; tree tmp; - tree stmt; tree stride, stride2; tree stmt_packed; tree stmt_unpacked; @@ -4504,10 +4483,13 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) /* Do nothing for pointer and allocatable arrays. */ if (sym->attr.pointer || sym->attr.allocatable) - return body; + return; if (sym->attr.dummy && gfc_is_nodesc_array (sym)) - return gfc_trans_g77_array (sym, body); + { + gfc_trans_g77_array (sym, block); + return; + } gfc_get_backend_locus (&loc); gfc_set_backend_locus (&sym->declared_at); @@ -4516,35 +4498,32 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) type = TREE_TYPE (tmpdesc); gcc_assert (GFC_ARRAY_TYPE_P (type)); dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); - dumdesc = build_fold_indirect_ref_loc (input_location, - dumdesc); - gfc_start_block (&block); + dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc); + gfc_start_block (&init); if (sym->ts.type == BT_CHARACTER && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL) - gfc_conv_string_length (sym->ts.u.cl, NULL, &block); + gfc_conv_string_length (sym->ts.u.cl, NULL, &init); checkparm = (sym->as->type == AS_EXPLICIT && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)); no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc) - || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc)); + || GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc)); if (GFC_DECL_PARTIAL_PACKED_ARRAY (tmpdesc)) { /* For non-constant shape arrays we only check if the first dimension - is contiguous. Repacking higher dimensions wouldn't gain us - anything as we still don't know the array stride. */ + is contiguous. Repacking higher dimensions wouldn't gain us + anything as we still don't know the array stride. */ partial = gfc_create_var (boolean_type_node, "partial"); TREE_USED (partial) = 1; tmp = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]); tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, gfc_index_one_node); - gfc_add_modify (&block, partial, tmp); + gfc_add_modify (&init, partial, tmp); } else - { - partial = NULL_TREE; - } + partial = NULL_TREE; /* The naming of stmt_unpacked and stmt_packed may be counter-intuitive here, however I think it does the right thing. */ @@ -4552,14 +4531,14 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) { /* Set the first stride. */ stride = gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[0]); - stride = gfc_evaluate_now (stride, &block); + stride = gfc_evaluate_now (stride, &init); tmp = fold_build2 (EQ_EXPR, boolean_type_node, stride, gfc_index_zero_node); tmp = fold_build3 (COND_EXPR, gfc_array_index_type, tmp, gfc_index_one_node, stride); stride = GFC_TYPE_ARRAY_STRIDE (type, 0); - gfc_add_modify (&block, stride, tmp); + gfc_add_modify (&init, stride, tmp); /* Allow the user to disable array repacking. */ stmt_unpacked = NULL_TREE; @@ -4594,7 +4573,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) } else tmp = stmt_packed != NULL_TREE ? stmt_packed : stmt_unpacked; - gfc_add_modify (&block, tmpdesc, fold_convert (type, tmp)); + gfc_add_modify (&init, tmpdesc, fold_convert (type, tmp)); offset = gfc_index_zero_node; size = gfc_index_one_node; @@ -4609,34 +4588,34 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) dlbound = gfc_conv_descriptor_lbound_get (dumdesc, gfc_rank_cst[n]); } else - { + { dubound = NULL_TREE; dlbound = NULL_TREE; - } + } lbound = GFC_TYPE_ARRAY_LBOUND (type, n); if (!INTEGER_CST_P (lbound)) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, sym->as->lower[n], - gfc_array_index_type); - gfc_add_block_to_block (&block, &se.pre); - gfc_add_modify (&block, lbound, se.expr); - } + { + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, sym->as->lower[n], + gfc_array_index_type); + gfc_add_block_to_block (&init, &se.pre); + gfc_add_modify (&init, lbound, se.expr); + } ubound = GFC_TYPE_ARRAY_UBOUND (type, n); /* Set the desired upper bound. */ if (sym->as->upper[n]) { /* We know what we want the upper bound to be. */ - if (!INTEGER_CST_P (ubound)) - { + if (!INTEGER_CST_P (ubound)) + { gfc_init_se (&se, NULL); gfc_conv_expr_type (&se, sym->as->upper[n], - gfc_array_index_type); - gfc_add_block_to_block (&block, &se.pre); - gfc_add_modify (&block, ubound, se.expr); - } + gfc_array_index_type); + gfc_add_block_to_block (&init, &se.pre); + gfc_add_modify (&init, ubound, se.expr); + } /* Check the sizes match. */ if (checkparm) @@ -4655,11 +4634,11 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) stride2 = fold_build2 (PLUS_EXPR, gfc_array_index_type, gfc_index_one_node, stride2); - tmp = fold_build2 (NE_EXPR, gfc_array_index_type, temp, stride2); + tmp = fold_build2 (NE_EXPR, gfc_array_index_type, temp, stride2); asprintf (&msg, "Dimension %d of array '%s' has extent " - "%%ld instead of %%ld", n+1, sym->name); + "%%ld instead of %%ld", n+1, sym->name); - gfc_trans_runtime_check (true, false, tmp, &block, &loc, msg, + gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg, fold_convert (long_integer_type_node, temp), fold_convert (long_integer_type_node, stride2)); @@ -4670,10 +4649,10 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) { /* For assumed shape arrays move the upper bound by the same amount as the lower bound. */ - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, dubound, dlbound); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound); - gfc_add_modify (&block, ubound, tmp); + tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, tmp, lbound); + gfc_add_modify (&init, ubound, tmp); } /* The offset of this dimension. offset = offset - lbound * stride. */ tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, lbound, stride); @@ -4681,41 +4660,39 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) /* The size of this dimension, and the stride of the next. */ if (n + 1 < sym->as->rank) - { - stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1); + { + stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1); - if (no_repack || partial != NULL_TREE) - { - stmt_unpacked = - gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]); - } + if (no_repack || partial != NULL_TREE) + stmt_unpacked = + gfc_conv_descriptor_stride_get (dumdesc, gfc_rank_cst[n+1]); - /* Figure out the stride if not a known constant. */ - if (!INTEGER_CST_P (stride)) - { - if (no_repack) - stmt_packed = NULL_TREE; - else - { - /* Calculate stride = size * (ubound + 1 - lbound). */ - tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, + /* Figure out the stride if not a known constant. */ + if (!INTEGER_CST_P (stride)) + { + if (no_repack) + stmt_packed = NULL_TREE; + else + { + /* Calculate stride = size * (ubound + 1 - lbound). */ + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, gfc_index_one_node, lbound); - tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, + tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type, ubound, tmp); - size = fold_build2 (MULT_EXPR, gfc_array_index_type, + size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp); - stmt_packed = size; - } + stmt_packed = size; + } - /* Assign the stride. */ - if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE) + /* Assign the stride. */ + if (stmt_packed != NULL_TREE && stmt_unpacked != NULL_TREE) tmp = fold_build3 (COND_EXPR, gfc_array_index_type, partial, stmt_unpacked, stmt_packed); - else - tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked; - gfc_add_modify (&block, stride, tmp); - } - } + else + tmp = (stmt_packed != NULL_TREE) ? stmt_packed : stmt_unpacked; + gfc_add_modify (&init, stride, tmp); + } + } else { stride = GFC_TYPE_ARRAY_SIZE (type); @@ -4729,20 +4706,18 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) ubound, tmp); tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, GFC_TYPE_ARRAY_STRIDE (type, n), tmp); - gfc_add_modify (&block, stride, tmp); + gfc_add_modify (&init, stride, tmp); } } } /* Set the offset. */ if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL) - gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset); - - gfc_trans_vla_type_sizes (sym, &block); + gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); - stmt = gfc_finish_block (&block); + gfc_trans_vla_type_sizes (sym, &init); - gfc_start_block (&block); + stmtInit = gfc_finish_block (&init); /* Only do the entry/initialization code if the arg is present. */ dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc); @@ -4752,18 +4727,18 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) if (optional_arg) { tmp = gfc_conv_expr_present (sym); - stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location)); + stmtInit = build3_v (COND_EXPR, tmp, stmtInit, + build_empty_stmt (input_location)); } - gfc_add_expr_to_block (&block, stmt); - - /* Add the main function body. */ - gfc_add_expr_to_block (&block, body); /* Cleanup code. */ - if (!no_repack) + if (no_repack) + stmtCleanup = NULL_TREE; + else { + stmtblock_t cleanup; gfc_start_block (&cleanup); - + if (sym->attr.intent != INTENT_IN) { /* Copy the data back. */ @@ -4776,26 +4751,26 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) tmp = gfc_call_free (tmpdesc); gfc_add_expr_to_block (&cleanup, tmp); - stmt = gfc_finish_block (&cleanup); + stmtCleanup = gfc_finish_block (&cleanup); /* Only do the cleanup if the array was repacked. */ - tmp = build_fold_indirect_ref_loc (input_location, - dumdesc); + tmp = build_fold_indirect_ref_loc (input_location, dumdesc); tmp = gfc_conv_descriptor_data_get (tmp); tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, tmpdesc); - stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location)); + stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup, + build_empty_stmt (input_location)); if (optional_arg) - { - tmp = gfc_conv_expr_present (sym); - stmt = build3_v (COND_EXPR, tmp, stmt, - build_empty_stmt (input_location)); - } - gfc_add_expr_to_block (&block, stmt); + { + tmp = gfc_conv_expr_present (sym); + stmtCleanup = build3_v (COND_EXPR, tmp, stmtCleanup, + build_empty_stmt (input_location)); + } } + /* We don't need to free any memory allocated by internal_pack as it will be freed at the end of the function by pop_context. */ - return gfc_finish_block (&block); + gfc_add_init_cleanup (block, stmtInit, stmtCleanup); } @@ -5355,7 +5330,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) gcc_assert (info->dim[dim] == n); /* Evaluate and remember the start of the section. */ - start = info->start[dim]; + start = info->start[n]; stride = gfc_evaluate_now (stride, &loop.pre); } @@ -5402,11 +5377,11 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) /* Multiply the stride by the section stride to get the total stride. */ stride = fold_build2 (MULT_EXPR, gfc_array_index_type, - stride, info->stride[dim]); + stride, info->stride[n]); if (se->direct_byref - && info->ref - && info->ref->u.ar.type != AR_FULL) + && info->ref + && info->ref->u.ar.type != AR_FULL) { base = fold_build2 (MINUS_EXPR, TREE_TYPE (base), base, stride); @@ -6265,13 +6240,14 @@ gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank) Do likewise, recursively if necessary, with the allocatable components of derived types. */ -tree -gfc_trans_deferred_array (gfc_symbol * sym, tree body) +void +gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) { tree type; tree tmp; tree descriptor; - stmtblock_t fnblock; + stmtblock_t init; + stmtblock_t cleanup; locus loc; int rank; bool sym_has_alloc_comp; @@ -6285,7 +6261,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body) "allocatable attribute or derived type without allocatable " "components."); - gfc_init_block (&fnblock); + gfc_init_block (&init); gcc_assert (TREE_CODE (sym->backend_decl) == VAR_DECL || TREE_CODE (sym->backend_decl) == PARM_DECL); @@ -6293,16 +6269,15 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body) if (sym->ts.type == BT_CHARACTER && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) { - gfc_conv_string_length (sym->ts.u.cl, NULL, &fnblock); - gfc_trans_vla_type_sizes (sym, &fnblock); + gfc_conv_string_length (sym->ts.u.cl, NULL, &init); + gfc_trans_vla_type_sizes (sym, &init); } /* Dummy, use associated and result variables don't need anything special. */ if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result) { - gfc_add_expr_to_block (&fnblock, body); - - return gfc_finish_block (&fnblock); + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); + return; } gfc_get_backend_locus (&loc); @@ -6316,7 +6291,9 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body) { /* SAVEd variables are not freed on exit. */ gfc_trans_static_array_pointer (sym); - return body; + + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); + return; } /* Get the descriptor type. */ @@ -6331,14 +6308,12 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body) || !gfc_has_default_initializer (sym->ts.u.derived)) { rank = sym->as ? sym->as->rank : 0; - tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, descriptor, rank); - gfc_add_expr_to_block (&fnblock, tmp); + tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, + descriptor, rank); + gfc_add_expr_to_block (&init, tmp); } else - { - tmp = gfc_init_default_dt (sym, NULL, false); - gfc_add_expr_to_block (&fnblock, tmp); - } + gfc_init_default_dt (sym, &init, false); } } else if (!GFC_DESCRIPTOR_TYPE_P (type)) @@ -6346,16 +6321,15 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body) /* If the backend_decl is not a descriptor, we must have a pointer to one. */ descriptor = build_fold_indirect_ref_loc (input_location, - sym->backend_decl); + sym->backend_decl); type = TREE_TYPE (descriptor); } /* NULLIFY the data pointer. */ if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save) - gfc_conv_descriptor_data_set (&fnblock, descriptor, null_pointer_node); - - gfc_add_expr_to_block (&fnblock, body); + gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node); + gfc_init_block (&cleanup); gfc_set_backend_locus (&loc); /* Allocatable arrays need to be freed when they go out of scope. @@ -6366,17 +6340,18 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body) int rank; rank = sym->as ? sym->as->rank : 0; tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, descriptor, rank); - gfc_add_expr_to_block (&fnblock, tmp); + gfc_add_expr_to_block (&cleanup, tmp); } if (sym->attr.allocatable && sym->attr.dimension && !sym->attr.save && !sym->attr.result) { tmp = gfc_trans_dealloc_allocated (sym->backend_decl); - gfc_add_expr_to_block (&fnblock, tmp); + gfc_add_expr_to_block (&cleanup, tmp); } - return gfc_finish_block (&fnblock); + gfc_add_init_cleanup (block, gfc_finish_block (&init), + gfc_finish_block (&cleanup)); } /************ Expression Walking Functions ******************/ |