diff options
Diffstat (limited to 'gcc/fortran/trans-array.cc')
| -rw-r--r-- | gcc/fortran/trans-array.cc | 178 |
1 files changed, 124 insertions, 54 deletions
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 6b759d1..0449c26 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -284,16 +284,6 @@ gfc_conv_descriptor_data_set (stmtblock_t *block, tree desc, tree value) } -/* This provides address access to the data field. This should only be - used by array allocation, passing this on to the runtime. */ - -tree -gfc_conv_descriptor_data_addr (tree desc) -{ - tree field = gfc_get_descriptor_field (desc, DATA_FIELD); - return gfc_build_addr_expr (NULL_TREE, field); -} - static tree gfc_conv_descriptor_offset (tree desc) { @@ -1426,12 +1416,6 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype, tmp2 = gfc_class_len_get (class_expr); gfc_add_modify (pre, tmp, tmp2); } - - if (rhs_function) - { - tmp = gfc_class_data_get (class_expr); - gfc_conv_descriptor_offset_set (pre, tmp, gfc_index_zero_node); - } } else if (rhs_ss->info->data.array.descriptor) { @@ -3121,7 +3105,6 @@ trans_array_constructor (gfc_ss * ss, locus * where) gfc_array_index_type, offsetvar, gfc_index_one_node); tmp = gfc_evaluate_now (tmp, &outer_loop->pre); - gfc_conv_descriptor_ubound_set (&loop->pre, desc, gfc_rank_cst[0], tmp); if (*loop_ubound0 && VAR_P (*loop_ubound0)) gfc_add_modify (&outer_loop->pre, *loop_ubound0, tmp); else @@ -3372,18 +3355,51 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, break; case GFC_SS_FUNCTION: - /* Array function return value. We call the function and save its - result in a temporary for use inside the loop. */ - gfc_init_se (&se, NULL); - se.loop = loop; - se.ss = ss; - if (gfc_is_class_array_function (expr)) - expr->must_finalize = 1; - gfc_conv_expr (&se, expr); - gfc_add_block_to_block (&outer_loop->pre, &se.pre); - gfc_add_block_to_block (&outer_loop->post, &se.post); - gfc_add_block_to_block (&outer_loop->post, &se.finalblock); - ss_info->string_length = se.string_length; + { + /* Array function return value. We call the function and save its + result in a temporary for use inside the loop. */ + gfc_init_se (&se, NULL); + se.loop = loop; + se.ss = ss; + bool class_func = gfc_is_class_array_function (expr); + if (class_func) + expr->must_finalize = 1; + gfc_conv_expr (&se, expr); + gfc_add_block_to_block (&outer_loop->pre, &se.pre); + if (class_func + && se.expr + && GFC_CLASS_TYPE_P (TREE_TYPE (se.expr))) + { + tree tmp = gfc_class_data_get (se.expr); + info->descriptor = tmp; + info->data = gfc_conv_descriptor_data_get (tmp); + info->offset = gfc_conv_descriptor_offset_get (tmp); + for (gfc_ss *s = ss; s; s = s->parent) + for (int n = 0; n < s->dimen; n++) + { + int dim = s->dim[n]; + tree tree_dim = gfc_rank_cst[dim]; + + tree start; + start = gfc_conv_descriptor_lbound_get (tmp, tree_dim); + start = gfc_evaluate_now (start, &outer_loop->pre); + info->start[dim] = start; + + tree end; + end = gfc_conv_descriptor_ubound_get (tmp, tree_dim); + end = gfc_evaluate_now (end, &outer_loop->pre); + info->end[dim] = end; + + tree stride; + stride = gfc_conv_descriptor_stride_get (tmp, tree_dim); + stride = gfc_evaluate_now (stride, &outer_loop->pre); + info->stride[dim] = stride; + } + } + gfc_add_block_to_block (&outer_loop->post, &se.post); + gfc_add_block_to_block (&outer_loop->post, &se.finalblock); + ss_info->string_length = se.string_length; + } break; case GFC_SS_CONSTRUCTOR: @@ -5383,7 +5399,8 @@ done: int dim = ss->dim[n]; info->start[dim] = gfc_index_zero_node; - info->end[dim] = gfc_index_zero_node; + if (ss_info->type != GFC_SS_FUNCTION) + info->end[dim] = gfc_index_zero_node; info->stride[dim] = gfc_index_one_node; } break; @@ -6068,6 +6085,46 @@ set_loop_bounds (gfc_loopinfo *loop) } +/* Last attempt to set the loop bounds, in case they depend on an allocatable + function result. */ + +static void +late_set_loop_bounds (gfc_loopinfo *loop) +{ + int n, dim; + gfc_array_info *info; + gfc_ss **loopspec; + + loopspec = loop->specloop; + + for (n = 0; n < loop->dimen; n++) + { + /* Set the extents of this range. */ + if (loop->from[n] == NULL_TREE + || loop->to[n] == NULL_TREE) + { + /* We should have found the scalarization loop specifier. If not, + that's bad news. */ + gcc_assert (loopspec[n]); + + info = &loopspec[n]->info->data.array; + dim = loopspec[n]->dim[n]; + + if (loopspec[n]->info->type == GFC_SS_FUNCTION + && info->start[dim] + && info->end[dim]) + { + loop->from[n] = info->start[dim]; + loop->to[n] = info->end[dim]; + } + } + } + + for (loop = loop->nested; loop; loop = loop->next) + late_set_loop_bounds (loop); +} + + /* Initialize the scalarization loop. Creates the loop variables. Determines the range of the loop variables. Creates a temporary if required. Also generates code for scalar expressions which have been @@ -6086,6 +6143,8 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) allocating the temporary. */ gfc_add_loop_ss_code (loop, loop->ss, false, where); + late_set_loop_bounds (loop); + tmp_ss = loop->temp_ss; /* If we want a temporary then create it. */ if (tmp_ss != NULL) @@ -6142,9 +6201,11 @@ gfc_set_delta (gfc_loopinfo *loop) gfc_ss_type ss_type; ss_type = ss->info->type; - if (ss_type != GFC_SS_SECTION - && ss_type != GFC_SS_COMPONENT - && ss_type != GFC_SS_CONSTRUCTOR) + if (!(ss_type == GFC_SS_SECTION + || ss_type == GFC_SS_COMPONENT + || ss_type == GFC_SS_CONSTRUCTOR + || (ss_type == GFC_SS_FUNCTION + && gfc_is_class_array_function (ss->info->expr)))) continue; info = &ss->info->data.array; @@ -6296,8 +6357,8 @@ static tree gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock, stmtblock_t * descriptor_block, tree * overflow, - tree expr3_elem_size, tree *nelems, gfc_expr *expr3, - tree expr3_desc, bool e3_has_nodescriptor, gfc_expr *expr, + tree expr3_elem_size, gfc_expr *expr3, tree expr3_desc, + bool e3_has_nodescriptor, gfc_expr *expr, tree *element_size, bool explicit_ts) { tree type; @@ -6573,7 +6634,6 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, if (rank == 0) return *element_size; - *nelems = gfc_evaluate_now (stride, pblock); stride = fold_convert (size_type_node, stride); /* First check for overflow. Since an array of type character can @@ -6662,9 +6722,8 @@ retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in) bool gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, tree errlen, tree label_finish, tree expr3_elem_size, - tree *nelems, gfc_expr *expr3, tree e3_arr_desc, - bool e3_has_nodescriptor, gfc_omp_namelist *omp_alloc, - bool explicit_ts) + gfc_expr *expr3, tree e3_arr_desc, bool e3_has_nodescriptor, + gfc_omp_namelist *omp_alloc, bool explicit_ts) { tree tmp; tree pointer; @@ -6795,7 +6854,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, coarray ? ref->u.ar.as->corank : 0, &offset, lower, upper, &se->pre, &set_descriptor_block, &overflow, - expr3_elem_size, nelems, expr3, e3_arr_desc, + expr3_elem_size, expr3, e3_arr_desc, e3_has_nodescriptor, expr, &element_size, explicit_ts); @@ -8439,14 +8498,6 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) else gcc_assert (se->ss == ss); - if (!is_pointer_array (se->expr)) - { - tmp = gfc_get_element_type (TREE_TYPE (se->expr)); - tmp = fold_convert (gfc_array_index_type, - size_in_bytes (tmp)); - gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp); - } - se->expr = gfc_build_addr_expr (NULL_TREE, se->expr); gfc_conv_expr (se, expr); @@ -9518,9 +9569,8 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77, new_field = gfc_conv_descriptor_dtype (new_desc); gfc_add_modify (&se->pre, new_field, old_field); - old_field = gfc_conv_descriptor_offset (old_desc); - new_field = gfc_conv_descriptor_offset (new_desc); - gfc_add_modify (&se->pre, new_field, old_field); + old_field = gfc_conv_descriptor_offset_get (old_desc); + gfc_conv_descriptor_offset_set (&se->pre, new_desc, old_field); for (int i = 0; i < expr->rank; i++) { @@ -10660,6 +10710,15 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, cdecl, NULL_TREE); dcmp = fold_convert (TREE_TYPE (comp), dcmp); + if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pdt_type + && !c->attr.allocatable) + { + tmp = gfc_copy_alloc_comp (c->ts.u.derived, comp, dcmp, + 0, 0); + gfc_add_expr_to_block (&fnblock, tmp); + continue; + } + if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable) { tree ftn_tree; @@ -10779,7 +10838,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, false, false, size, NULL_TREE); gfc_add_expr_to_block (&fnblock, tmp); } - else if (c->attr.pdt_array) + else if (c->attr.pdt_array + && !c->attr.allocatable && !c->attr.pointer) { tmp = duplicate_allocatable (dcmp, comp, ctype, c->as ? c->as->rank : 0, @@ -10846,6 +10906,16 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, gfc_add_modify (&fnblock, comp, tse.expr); } } + else if (c->initializer && !c->attr.pdt_string && !c->attr.pdt_array + && !c->as && !(c->ts.type == BT_DERIVED + && c->ts.u.derived->attr.pdt_type)) /* Take care of arrays. */ + { + gfc_se tse; + gfc_expr *c_expr; + c_expr = c->initializer; + gfc_conv_expr_type (&tse, c_expr, TREE_TYPE (comp)); + gfc_add_modify (&fnblock, comp, tse.expr); + } if (c->attr.pdt_string) { @@ -11690,8 +11760,8 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, gfc_index_zero_node); } - tmp = gfc_conv_descriptor_offset (desc); - gfc_add_modify (&loop_pre_block, tmp, gfc_index_zero_node); + gfc_conv_descriptor_offset_set (&loop_pre_block, desc, + gfc_index_zero_node); tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, array1, |