X-Git-Url: http://git.sourceforge.jp/view?p=pf3gnuchains%2Fgcc-fork.git;a=blobdiff_plain;f=gcc%2Ffortran%2Ftrans-array.c;h=e3134f5efa9e485d0f99cc2205a105a5d2a9aa53;hp=29c7f835475ebde0f081697f1a42806254e5b9fd;hb=4d0a8b9d7a3cdf29a03dce0098f74fdcad38e81e;hpb=a961ca300d569b8bc5361efd28e88d49ca667928 diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 29c7f835475..e3134f5efa9 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -129,6 +129,7 @@ gfc_array_dataptr_type (tree desc) #define OFFSET_FIELD 1 #define DTYPE_FIELD 2 #define DIMENSION_FIELD 3 +#define CAF_TOKEN_FIELD 4 #define STRIDE_SUBFIELD 0 #define LBOUND_SUBFIELD 1 @@ -267,6 +268,25 @@ gfc_conv_descriptor_dimension (tree desc, tree dim) return tmp; } + +tree +gfc_conv_descriptor_token (tree desc) +{ + tree type; + tree field; + + type = TREE_TYPE (desc); + gcc_assert (GFC_DESCRIPTOR_TYPE_P (type)); + gcc_assert (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE); + gcc_assert (gfc_option.coarray == GFC_FCOARRAY_LIB); + field = gfc_advance_chain (TYPE_FIELDS (type), CAF_TOKEN_FIELD); + gcc_assert (field != NULL_TREE && TREE_TYPE (field) == prvoid_type_node); + + return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), + desc, field, NULL_TREE); +} + + static tree gfc_conv_descriptor_stride (tree desc, tree dim) { @@ -429,6 +449,7 @@ gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc, #undef OFFSET_FIELD #undef DTYPE_FIELD #undef DIMENSION_FIELD +#undef CAF_TOKEN_FIELD #undef STRIDE_SUBFIELD #undef LBOUND_SUBFIELD #undef UBOUND_SUBFIELD @@ -490,6 +511,62 @@ gfc_free_ss (gfc_ss * ss) } +/* Creates and initializes an array type gfc_ss struct. */ + +gfc_ss * +gfc_get_array_ss (gfc_ss *next, gfc_expr *expr, int dimen, gfc_ss_type type) +{ + gfc_ss *ss; + gfc_ss_info *info; + int i; + + ss = gfc_get_ss (); + ss->next = next; + ss->type = type; + ss->expr = expr; + info = &ss->data.info; + info->dimen = dimen; + for (i = 0; i < info->dimen; i++) + info->dim[i] = i; + + return ss; +} + + +/* Creates and initializes a temporary type gfc_ss struct. */ + +gfc_ss * +gfc_get_temp_ss (tree type, tree string_length, int dimen) +{ + gfc_ss *ss; + + ss = gfc_get_ss (); + ss->next = gfc_ss_terminator; + ss->type = GFC_SS_TEMP; + ss->string_length = string_length; + ss->data.temp.dimen = dimen; + ss->data.temp.type = type; + + return ss; +} + + +/* Creates and initializes a scalar type gfc_ss struct. */ + +gfc_ss * +gfc_get_scalar_ss (gfc_ss *next, gfc_expr *expr) +{ + gfc_ss *ss; + + ss = gfc_get_ss (); + ss->next = next; + ss->type = GFC_SS_SCALAR; + ss->expr = expr; + + return ss; +} + + /* Free all the SS associated with a loop. */ void @@ -563,7 +640,7 @@ gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping, tree tmp; if (as && as->type == AS_EXPLICIT) - for (n = 0; n < se->loop->dimen + se->loop->codimen; n++) + for (n = 0; n < se->loop->dimen; n++) { dim = se->ss->data.info.dim[n]; gcc_assert (dim < as->rank); @@ -577,22 +654,18 @@ gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping * mapping, gfc_add_block_to_block (&se->post, &tmpse.post); lower = fold_convert (gfc_array_index_type, tmpse.expr); - if (se->loop->codimen == 0 - || n < se->loop->dimen + se->loop->codimen - 1) - { - /* ...and the upper bound. */ - gfc_init_se (&tmpse, NULL); - gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]); - gfc_add_block_to_block (&se->pre, &tmpse.pre); - gfc_add_block_to_block (&se->post, &tmpse.post); - upper = fold_convert (gfc_array_index_type, tmpse.expr); - - /* Set the upper bound of the loop to UPPER - LOWER. */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, upper, lower); - tmp = gfc_evaluate_now (tmp, &se->pre); - se->loop->to[n] = tmp; - } + /* ...and the upper bound. */ + gfc_init_se (&tmpse, NULL); + gfc_apply_interface_mapping (mapping, &tmpse, as->upper[dim]); + gfc_add_block_to_block (&se->pre, &tmpse.pre); + gfc_add_block_to_block (&se->post, &tmpse.post); + upper = fold_convert (gfc_array_index_type, tmpse.expr); + + /* Set the upper bound of the loop to UPPER - LOWER. */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, upper, lower); + tmp = gfc_evaluate_now (tmp, &se->pre); + se->loop->to[n] = tmp; } } } @@ -899,13 +972,6 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, size, tmp); size = gfc_evaluate_now (size, pre); } - for (n = info->dimen; n < info->dimen + info->codimen; n++) - { - gfc_conv_descriptor_lbound_set (pre, desc, gfc_rank_cst[n], - gfc_index_zero_node); - if (n < info->dimen + info->codimen - 1) - gfc_conv_descriptor_ubound_set (pre, desc, gfc_rank_cst[n], loop->to[n]); - } /* Get the size of the array. */ @@ -1392,8 +1458,8 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, size = TREE_INT_CST_LOW (TYPE_SIZE_UNIT (type)); bound = build_int_cst (size_type_node, n * size); tmp = build_call_expr_loc (input_location, - built_in_decls[BUILT_IN_MEMCPY], 3, - tmp, init, bound); + builtin_decl_explicit (BUILT_IN_MEMCPY), + 3, tmp, init, bound); gfc_add_expr_to_block (&body, tmp); *poffset = fold_build2_loc (input_location, PLUS_EXPR, @@ -1798,13 +1864,12 @@ gfc_trans_constant_array_constructor (gfc_loopinfo * loop, info->data = gfc_build_addr_expr (NULL_TREE, tmp); info->offset = gfc_index_zero_node; - for (i = 0; i < info->dimen + info->codimen; i++) + for (i = 0; i < info->dimen; i++) { info->delta[i] = gfc_index_zero_node; info->start[i] = gfc_index_zero_node; info->end[i] = gfc_index_zero_node; info->stride[i] = gfc_index_one_node; - info->dim[i] = i; } if (info->dimen > loop->temp_dim) @@ -1883,7 +1948,7 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where) first_len = true; } - ss->data.info.dimen = loop->dimen; + gcc_assert (ss->data.info.dimen == loop->dimen); c = ss->expr->value.constructor; if (ss->expr->ts.type == BT_CHARACTER) @@ -2039,7 +2104,7 @@ gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info) int n; int dim; - for (n = 0; n < loop->dimen + loop->codimen; n++) + for (n = 0; n < loop->dimen; n++) { dim = info->dim[n]; if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR @@ -2244,7 +2309,7 @@ gfc_init_loopinfo (gfc_loopinfo * loop) for (n = 0; n < GFC_MAX_DIMENSIONS; n++) { loop->order[n] = n; - loop->reverse[n] = GFC_CANNOT_REVERSE; + loop->reverse[n] = GFC_INHIBIT_REVERSE; } loop->ss = gfc_ss_terminator; @@ -2544,6 +2609,18 @@ 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]]; + + /* Pointer functions can have stride[0] different from unity. + Use the stride returned by the function call and stored in + the descriptor for the temporary. */ + if (se->ss && se->ss->type == GFC_SS_FUNCTION + && se->ss->expr + && se->ss->expr->symtree + && se->ss->expr->symtree->n.sym->result + && se->ss->expr->symtree->n.sym->result->attr.pointer) + stride = gfc_conv_descriptor_stride_get (info->descriptor, + gfc_rank_cst[dim]); + if (!integer_zerop (info->delta[dim])) index = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, index, info->delta[dim]); @@ -2602,6 +2679,22 @@ gfc_conv_tmp_array_ref (gfc_se * se) gfc_advance_se_ss_chain (se); } +/* Add T to the offset pair *OFFSET, *CST_OFFSET. */ + +static void +add_to_offset (tree *cst_offset, tree *offset, tree t) +{ + if (TREE_CODE (t) == INTEGER_CST) + *cst_offset = int_const_binop (PLUS_EXPR, *cst_offset, t); + else + { + if (!integer_zerop (*offset)) + *offset = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, *offset, t); + else + *offset = t; + } +} /* Build an array reference. se->expr already holds the array descriptor. This should be either a variable, indirect variable reference or component @@ -2614,7 +2707,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym, locus * where) { int n; - tree index; + tree offset, cst_offset; tree tmp; tree stride; gfc_se indexse; @@ -2623,12 +2716,21 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym, if (ar->dimen == 0) { gcc_assert (ar->codimen); - if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr)) - && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE) - se->expr = build_fold_indirect_ref_loc (input_location, se->expr); - /* Use the actual tree type and not the wrapped coarray. */ - se->expr = fold_convert (TREE_TYPE (TREE_TYPE (se->expr)), se->expr); + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr))) + se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr)); + else + { + if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr)) + && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE) + se->expr = build_fold_indirect_ref_loc (input_location, se->expr); + + /* Use the actual tree type and not the wrapped coarray. */ + if (!se->want_pointer) + se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)), + se->expr); + } + return; } @@ -2640,10 +2742,12 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym, return; } - index = gfc_index_zero_node; + cst_offset = offset = gfc_index_zero_node; + add_to_offset (&cst_offset, &offset, gfc_conv_array_offset (se->expr)); - /* Calculate the offsets from all the dimensions. */ - for (n = 0; n < ar->dimen; n++) + /* Calculate the offsets from all the dimensions. Make sure to associate + the final offset so that we form a chain of loop invariant summands. */ + for (n = ar->dimen - 1; n >= 0; n--) { /* Calculate the index for this dimension. */ gfc_init_se (&indexse, se); @@ -2712,19 +2816,17 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym, indexse.expr, stride); /* And add it to the total. */ - index = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, index, tmp); + add_to_offset (&cst_offset, &offset, tmp); } - tmp = gfc_conv_array_offset (se->expr); - if (!integer_zerop (tmp)) - index = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, index, tmp); + if (!integer_zerop (cst_offset)) + offset = fold_build2_loc (input_location, PLUS_EXPR, + gfc_array_index_type, offset, cst_offset); /* Access the calculated element. */ tmp = gfc_conv_array_data (se->expr); tmp = build_fold_indirect_ref (tmp); - se->expr = gfc_build_array_ref (tmp, index, sym->backend_decl); + se->expr = gfc_build_array_ref (tmp, offset, sym->backend_decl); } @@ -2740,6 +2842,7 @@ gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag, gfc_ss_info *info; gfc_ss *ss; gfc_se se; + gfc_array_ref *ar; int i; /* This code will be executed before entering the scalarization loop @@ -2759,16 +2862,38 @@ gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag, if (dim >= info->dimen) continue; + if (info->ref) + ar = &info->ref->u.ar; + else + ar = NULL; + + i = dim + 1; + + /* For the time being, there is no loop reordering. */ + gcc_assert (i == loop->order[i]); + i = loop->order[i]; + if (dim == info->dimen - 1) { + i = loop->order[0]; + /* For the time being, the innermost loop is unconditionally on + the first dimension of the scalarization loop. */ + gcc_assert (i == 0); + stride = gfc_conv_array_stride (info->descriptor, info->dim[i]); + + /* Calculate the stride of the innermost loop. Hopefully this will + allow the backend optimizers to do their stuff more effectively. + */ + info->stride0 = gfc_evaluate_now (stride, pblock); + /* For the outermost loop calculate the offset due to any elemental dimensions. It will have been initialized with the base offset of the array. */ if (info->ref) { - for (i = 0; i < info->ref->u.ar.dimen; i++) + for (i = 0; i < ar->dimen; i++) { - if (info->ref->u.ar.dimen_type[i] != DIMEN_ELEMENT) + if (ar->dimen_type[i] != DIMEN_ELEMENT) continue; gfc_init_se (&se, NULL); @@ -2776,8 +2901,7 @@ gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag, se.expr = info->descriptor; stride = gfc_conv_array_stride (info->descriptor, i); index = gfc_conv_array_index_offset (&se, info, i, -1, - &info->ref->u.ar, - stride); + ar, stride); gfc_add_block_to_block (pblock, &se.pre); info->offset = fold_build2_loc (input_location, PLUS_EXPR, @@ -2786,34 +2910,10 @@ gfc_trans_preloop_setup (gfc_loopinfo * loop, int dim, int flag, info->offset = gfc_evaluate_now (info->offset, pblock); } } - - i = loop->order[0]; - /* For the time being, the innermost loop is unconditionally on - the first dimension of the scalarization loop. */ - gcc_assert (i == 0); - stride = gfc_conv_array_stride (info->descriptor, info->dim[i]); - - /* Calculate the stride of the innermost loop. Hopefully this will - allow the backend optimizers to do their stuff more effectively. - */ - info->stride0 = gfc_evaluate_now (stride, pblock); } else { /* Add the offset for the previous loop dimension. */ - gfc_array_ref *ar; - - if (info->ref) - { - ar = &info->ref->u.ar; - i = loop->order[dim + 1]; - } - else - { - ar = NULL; - i = dim + 1; - } - gfc_init_se (&se, NULL); se.loop = loop; se.expr = info->descriptor; @@ -2846,7 +2946,7 @@ gfc_start_scalarized_body (gfc_loopinfo * loop, stmtblock_t * pbody) gcc_assert (!loop->array_parameter); - for (dim = loop->dimen + loop->codimen - 1; dim >= 0; dim--) + for (dim = loop->dimen - 1; dim >= 0; dim--) { n = loop->order[dim]; @@ -3000,7 +3100,7 @@ gfc_trans_scalarizing_loops (gfc_loopinfo * loop, stmtblock_t * body) pblock = body; /* Generate the loops. */ - for (dim = 0; dim < loop->dimen + loop->codimen; dim++) + for (dim = 0; dim < loop->dimen; dim++) { n = loop->order[dim]; gfc_trans_scalarized_loop_end (loop, n, pblock); @@ -3073,82 +3173,83 @@ gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body) } +/* Precalculate (either lower or upper) bound of an array section. + BLOCK: Block in which the (pre)calculation code will go. + BOUNDS[DIM]: Where the bound value will be stored once evaluated. + VALUES[DIM]: Specified bound (NULL <=> unspecified). + DESC: Array descriptor from which the bound will be picked if unspecified + (either lower or upper bound according to LBOUND). */ + +static void +evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values, + tree desc, int dim, bool lbound) +{ + gfc_se se; + gfc_expr * input_val = values[dim]; + tree *output = &bounds[dim]; + + + if (input_val) + { + /* Specified section bound. */ + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, input_val, gfc_array_index_type); + gfc_add_block_to_block (block, &se.pre); + *output = se.expr; + } + else + { + /* No specific bound specified so use the bound of the array. */ + *output = lbound ? gfc_conv_array_lbound (desc, dim) : + gfc_conv_array_ubound (desc, dim); + } + *output = gfc_evaluate_now (*output, block); +} + + /* Calculate the lower bound of an array section. */ static void -gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim, - bool coarray, bool coarray_last) +gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int dim) { - gfc_expr *start; - gfc_expr *end; gfc_expr *stride = NULL; tree desc; gfc_se se; gfc_ss_info *info; + gfc_array_ref *ar; gcc_assert (ss->type == GFC_SS_SECTION); info = &ss->data.info; + ar = &info->ref->u.ar; - if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR) + if (ar->dimen_type[dim] == DIMEN_VECTOR) { /* We use a zero-based index to access the vector. */ info->start[dim] = gfc_index_zero_node; info->end[dim] = NULL; - if (!coarray) - info->stride[dim] = gfc_index_one_node; + info->stride[dim] = gfc_index_one_node; return; } - gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE); + gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE + || ar->dimen_type[dim] == DIMEN_THIS_IMAGE); desc = info->descriptor; - start = info->ref->u.ar.start[dim]; - end = info->ref->u.ar.end[dim]; - if (!coarray) - stride = info->ref->u.ar.stride[dim]; + stride = ar->stride[dim]; /* Calculate the start of the range. For vector subscripts this will be the range of the vector. */ - if (start) - { - /* Specified section start. */ - 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[dim] = se.expr; - } - else - { - /* No lower bound specified so use the bound of the array. */ - info->start[dim] = gfc_conv_array_lbound (desc, dim); - } - info->start[dim] = gfc_evaluate_now (info->start[dim], &loop->pre); + evaluate_bound (&loop->pre, info->start, ar->start, desc, dim, true); /* Similarly calculate the end. Although this is not used in the scalarizer, it is needed when checking bounds and where the end is an expression with side-effects. */ - if (!coarray_last) - { - if (end) - { - /* Specified section start. */ - 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[dim] = se.expr; - } - else - { - /* No upper bound specified so use the bound of the array. */ - info->end[dim] = gfc_conv_array_ubound (desc, dim); - } - info->end[dim] = gfc_evaluate_now (info->end[dim], &loop->pre); - } + evaluate_bound (&loop->pre, info->end, ar->end, desc, dim, false); /* Calculate the stride. */ - if (!coarray && stride == NULL) + if (stride == NULL) info->stride[dim] = gfc_index_one_node; - else if (!coarray) + else { gfc_init_se (&se, NULL); gfc_conv_expr_type (&se, stride, gfc_array_index_type); @@ -3172,8 +3273,7 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) loop->dimen = 0; /* Determine the rank of the loop. */ - for (ss = loop->ss; - ss != gfc_ss_terminator && loop->dimen == 0; ss = ss->loop_chain) + for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) { switch (ss->type) { @@ -3182,8 +3282,7 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) case GFC_SS_FUNCTION: case GFC_SS_COMPONENT: loop->dimen = ss->data.info.dimen; - loop->codimen = ss->data.info.codimen; - break; + goto done; /* As usual, lbound and ubound are exceptions!. */ case GFC_SS_INTRINSIC: @@ -3191,16 +3290,11 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) { case GFC_ISYM_LBOUND: case GFC_ISYM_UBOUND: - loop->dimen = ss->data.info.dimen; - loop->codimen = 0; - break; - case GFC_ISYM_LCOBOUND: case GFC_ISYM_UCOBOUND: case GFC_ISYM_THIS_IMAGE: loop->dimen = ss->data.info.dimen; - loop->codimen = ss->data.info.codimen; - break; + goto done; default: break; @@ -3213,8 +3307,9 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) /* We should have determined the rank of the expression by now. If not, that's bad news. */ - gcc_assert (loop->dimen + loop->codimen != 0); + gcc_unreachable (); +done: /* Loop over all the SS in the chain. */ for (ss = loop->ss; ss != gfc_ss_terminator; ss = ss->loop_chain) { @@ -3228,14 +3323,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, ss->data.info.dim[n], - false, false); - for (n = ss->data.info.dimen; - n < ss->data.info.dimen + ss->data.info.codimen; n++) - gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n], true, - n == ss->data.info.dimen - + ss->data.info.codimen -1); - + gfc_conv_section_startstride (loop, ss, ss->data.info.dim[n]); break; case GFC_SS_INTRINSIC: @@ -3752,13 +3840,8 @@ temporary: if (GFC_ARRAY_TYPE_P (base_type) || GFC_DESCRIPTOR_TYPE_P (base_type)) base_type = gfc_get_element_type (base_type); - loop->temp_ss = gfc_get_ss (); - loop->temp_ss->type = GFC_SS_TEMP; - loop->temp_ss->data.temp.type = base_type; - loop->temp_ss->string_length = dest->string_length; - loop->temp_ss->data.temp.dimen = loop->dimen; - loop->temp_ss->data.temp.codimen = loop->codimen; - loop->temp_ss->next = gfc_ss_terminator; + loop->temp_ss = gfc_get_temp_ss (base_type, dest->string_length, + loop->dimen); gfc_add_ss_to_loop (loop, loop->temp_ss); } else @@ -3786,7 +3869,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) mpz_t i; mpz_init (i); - for (n = 0; n < loop->dimen + loop->codimen; n++) + for (n = 0; n < loop->dimen; n++) { loopspec[n] = NULL; dynamic[n] = false; @@ -3895,7 +3978,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) /* Set the extents of this range. */ cshape = loopspec[n]->shape; - if (n < loop->dimen && cshape && INTEGER_CST_P (info->start[dim]) + if (cshape && INTEGER_CST_P (info->start[dim]) && INTEGER_CST_P (info->stride[dim])) { loop->from[n] = info->start[dim]; @@ -4135,11 +4218,15 @@ gfc_conv_descriptor_cosize (tree desc, int rank, int corank) size = 1 - lbound; a.ubound[n] = specified_upper_bound; a.stride[n] = stride; - size = siz >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound + size = size >= 0 ? ubound + size : 0; //size = ubound + 1 - lbound overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0); stride = stride * size; } + for (n = rank; n < rank+corank; n++) + (Set lcobound/ucobound as above.) element_size = sizeof (array element); + if (!rank) + return element_size stride = (size_t) stride; overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0); stride = stride * element_size; @@ -4149,8 +4236,8 @@ gfc_conv_descriptor_cosize (tree desc, int rank, int corank) static tree gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, - gfc_expr ** lower, gfc_expr ** upper, - stmtblock_t * pblock, tree * overflow) + gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock, + stmtblock_t * descriptor_block, tree * overflow) { tree type; tree tmp; @@ -4176,7 +4263,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, /* Set the dtype. */ tmp = gfc_conv_descriptor_dtype (descriptor); - gfc_add_modify (pblock, tmp, gfc_get_dtype (TREE_TYPE (descriptor))); + gfc_add_modify (descriptor_block, tmp, gfc_get_dtype (TREE_TYPE (descriptor))); or_expr = boolean_false_node; @@ -4209,8 +4296,8 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, ubound = lower[n]; } } - gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n], - se.expr); + gfc_conv_descriptor_lbound_set (descriptor_block, descriptor, + gfc_rank_cst[n], se.expr); conv_lbound = se.expr; /* Work out the offset for this component. */ @@ -4225,12 +4312,12 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, gfc_conv_expr_type (&se, ubound, gfc_array_index_type); gfc_add_block_to_block (pblock, &se.pre); - gfc_conv_descriptor_ubound_set (pblock, descriptor, + gfc_conv_descriptor_ubound_set (descriptor_block, descriptor, gfc_rank_cst[n], se.expr); conv_ubound = se.expr; /* Store the stride. */ - gfc_conv_descriptor_stride_set (pblock, descriptor, + gfc_conv_descriptor_stride_set (descriptor_block, descriptor, gfc_rank_cst[n], stride); /* Calculate size and check whether extent is negative. */ @@ -4290,8 +4377,8 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, ubound = lower[n]; } } - gfc_conv_descriptor_lbound_set (pblock, descriptor, gfc_rank_cst[n], - se.expr); + gfc_conv_descriptor_lbound_set (descriptor_block, descriptor, + gfc_rank_cst[n], se.expr); if (n < rank + corank - 1) { @@ -4299,7 +4386,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, gcc_assert (ubound); gfc_conv_expr_type (&se, ubound, gfc_array_index_type); gfc_add_block_to_block (pblock, &se.pre); - gfc_conv_descriptor_ubound_set (pblock, descriptor, + gfc_conv_descriptor_ubound_set (descriptor_block, descriptor, gfc_rank_cst[n], se.expr); } } @@ -4309,6 +4396,10 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); /* Convert to size_t. */ element_size = fold_convert (size_type_node, tmp); + + if (rank == 0) + return element_size; + stride = fold_convert (size_type_node, stride); /* First check for overflow. Since an array of type character can @@ -4366,22 +4457,26 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, /*GCC ARRAYS*/ bool -gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat) +gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, + tree errlen) { tree tmp; tree pointer; - tree offset; + tree offset = NULL_TREE; + tree token = NULL_TREE; tree size; tree msg; - tree error; + tree error = NULL_TREE; tree overflow; /* Boolean storing whether size calculation overflows. */ - tree var_overflow; + tree var_overflow = NULL_TREE; tree cond; + tree set_descriptor; + stmtblock_t set_descriptor_block; stmtblock_t elseblock; gfc_expr **lower; gfc_expr **upper; gfc_ref *ref, *prev_ref = NULL; - bool allocatable_array, coarray; + bool allocatable, coarray, dimension; ref = expr->ref; @@ -4399,22 +4494,19 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat) if (!prev_ref) { - allocatable_array = expr->symtree->n.sym->attr.allocatable; + allocatable = expr->symtree->n.sym->attr.allocatable; coarray = expr->symtree->n.sym->attr.codimension; + dimension = expr->symtree->n.sym->attr.dimension; } else { - allocatable_array = prev_ref->u.c.component->attr.allocatable; + allocatable = prev_ref->u.c.component->attr.allocatable; coarray = prev_ref->u.c.component->attr.codimension; + dimension = prev_ref->u.c.component->attr.dimension; } - /* Return if this is a scalar coarray. */ - if ((!prev_ref && !expr->symtree->n.sym->attr.dimension) - || (prev_ref && !prev_ref->u.c.component->attr.dimension)) - { - gcc_assert (coarray); - return false; - } + if (!dimension) + gcc_assert (coarray); /* Figure out the size of the array. */ switch (ref->u.ar.type) @@ -4446,62 +4538,84 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat) } overflow = integer_zero_node; + + gfc_init_block (&set_descriptor_block); size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, ref->u.ar.as->corank, &offset, lower, upper, - &se->pre, &overflow); + &se->pre, &set_descriptor_block, &overflow); + + if (dimension) + { - var_overflow = gfc_create_var (integer_type_node, "overflow"); - gfc_add_modify (&se->pre, var_overflow, overflow); + var_overflow = gfc_create_var (integer_type_node, "overflow"); + gfc_add_modify (&se->pre, var_overflow, overflow); - /* Generate the block of code handling overflow. */ - msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const + /* Generate the block of code handling overflow. */ + msg = gfc_build_addr_expr (pchar_type_node, + gfc_build_localized_cstring_const ("Integer overflow when calculating the amount of " "memory to allocate")); - error = build_call_expr_loc (input_location, - gfor_fndecl_runtime_error, 1, msg); + error = build_call_expr_loc (input_location, gfor_fndecl_runtime_error, + 1, msg); + } - if (pstat != NULL_TREE && !integer_zerop (pstat)) + if (status != NULL_TREE) { - /* Set the status variable if it's present. */ + tree status_type = TREE_TYPE (status); stmtblock_t set_status_block; - tree status_type = pstat ? TREE_TYPE (TREE_TYPE (pstat)) : NULL_TREE; gfc_start_block (&set_status_block); - gfc_add_modify (&set_status_block, - fold_build1_loc (input_location, INDIRECT_REF, - status_type, pstat), - build_int_cst (status_type, LIBERROR_ALLOCATION)); - - tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, - pstat, build_int_cst (TREE_TYPE (pstat), 0)); - error = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp, - error, gfc_finish_block (&set_status_block)); + gfc_add_modify (&set_status_block, status, + build_int_cst (status_type, LIBERROR_ALLOCATION)); + error = gfc_finish_block (&set_status_block); } gfc_start_block (&elseblock); - + /* Allocate memory to store the data. */ pointer = gfc_conv_descriptor_data_get (se->expr); STRIP_NOPS (pointer); - /* The allocate_array variants take the old pointer as first argument. */ - if (allocatable_array) - tmp = gfc_allocate_array_with_status (&elseblock, pointer, size, pstat, expr); - else - tmp = gfc_allocate_with_status (&elseblock, size, pstat); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, pointer, - tmp); + if (coarray && gfc_option.coarray == GFC_FCOARRAY_LIB) + token = gfc_build_addr_expr (NULL_TREE, + gfc_conv_descriptor_token (se->expr)); - gfc_add_expr_to_block (&elseblock, tmp); + /* The allocatable variant takes the old pointer as first argument. */ + if (allocatable) + gfc_allocate_allocatable (&elseblock, pointer, size, token, + status, errmsg, errlen, expr); + else + gfc_allocate_using_malloc (&elseblock, pointer, size, status); - cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR, boolean_type_node, - var_overflow, integer_zero_node)); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, - error, gfc_finish_block (&elseblock)); + if (dimension) + { + cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR, + boolean_type_node, var_overflow, integer_zero_node)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, + error, gfc_finish_block (&elseblock)); + } + else + tmp = gfc_finish_block (&elseblock); gfc_add_expr_to_block (&se->pre, tmp); - gfc_conv_descriptor_offset_set (&se->pre, se->expr, offset); + /* Update the array descriptors. */ + if (dimension) + gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset); + + set_descriptor = gfc_finish_block (&set_descriptor_block); + if (status != NULL_TREE) + { + cond = fold_build2_loc (input_location, EQ_EXPR, + boolean_type_node, status, + build_int_cst (TREE_TYPE (status), 0)); + gfc_add_expr_to_block (&se->pre, + fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_likely (cond), set_descriptor, + build_empty_stmt (input_location))); + } + else + gfc_add_expr_to_block (&se->pre, set_descriptor); if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS) && expr->ts.u.derived->attr.alloc_comp) @@ -4555,7 +4669,7 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr) gfc_se se; HOST_WIDE_INT hi; unsigned HOST_WIDE_INT lo; - tree index; + tree index, range; VEC(constructor_elt,gc) *v = NULL; switch (expr->expr_type) @@ -4609,28 +4723,56 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr) else index = NULL_TREE; + if (mpz_cmp_si (c->repeat, 1) > 0) + { + tree tmp1, tmp2; + mpz_t maxval; + + mpz_init (maxval); + mpz_add (maxval, c->offset, c->repeat); + mpz_sub_ui (maxval, maxval, 1); + tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind); + if (mpz_cmp_si (c->offset, 0) != 0) + { + mpz_add_ui (maxval, c->offset, 1); + tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind); + } + else + tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind); + + range = fold_build2 (RANGE_EXPR, gfc_array_index_type, tmp1, tmp2); + mpz_clear (maxval); + } + else + range = NULL; + gfc_init_se (&se, NULL); switch (c->expr->expr_type) { case EXPR_CONSTANT: gfc_conv_constant (&se, c->expr); - CONSTRUCTOR_APPEND_ELT (v, index, se.expr); break; case EXPR_STRUCTURE: gfc_conv_structure (&se, c->expr, 1); - CONSTRUCTOR_APPEND_ELT (v, index, se.expr); break; - default: /* Catch those occasional beasts that do not simplify for one reason or another, assuming that if they are standard defying the frontend will catch them. */ gfc_conv_expr (&se, c->expr); - CONSTRUCTOR_APPEND_ELT (v, index, se.expr); break; } + + if (range == NULL_TREE) + CONSTRUCTOR_APPEND_ELT (v, index, se.expr); + else + { + if (index != NULL_TREE) + CONSTRUCTOR_APPEND_ELT (v, index, se.expr); + CONSTRUCTOR_APPEND_ELT (v, range, se.expr); + } } break; @@ -4648,6 +4790,43 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr) } +/* Generate code to evaluate non-constant coarray cobounds. */ + +void +gfc_trans_array_cobounds (tree type, stmtblock_t * pblock, + const gfc_symbol *sym) +{ + int dim; + tree ubound; + tree lbound; + gfc_se se; + gfc_array_spec *as; + + as = sym->as; + + for (dim = as->rank; dim < as->rank + as->corank; dim++) + { + /* Evaluate non-constant array bound expressions. */ + lbound = GFC_TYPE_ARRAY_LBOUND (type, dim); + if (as->lower[dim] && !INTEGER_CST_P (lbound)) + { + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type); + gfc_add_block_to_block (pblock, &se.pre); + gfc_add_modify (pblock, lbound, se.expr); + } + ubound = GFC_TYPE_ARRAY_UBOUND (type, dim); + if (as->upper[dim] && !INTEGER_CST_P (ubound)) + { + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type); + gfc_add_block_to_block (pblock, &se.pre); + gfc_add_modify (pblock, ubound, se.expr); + } + } +} + + /* Generate code to evaluate non-constant array bounds. Sets *poffset and returns the size (in elements) of the array. */ @@ -4728,26 +4907,8 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset, size = stride; } - for (dim = as->rank; dim < as->rank + as->corank; dim++) - { - /* Evaluate non-constant array bound expressions. */ - lbound = GFC_TYPE_ARRAY_LBOUND (type, dim); - if (as->lower[dim] && !INTEGER_CST_P (lbound)) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - gfc_add_modify (pblock, lbound, se.expr); - } - ubound = GFC_TYPE_ARRAY_UBOUND (type, dim); - if (as->upper[dim] && !INTEGER_CST_P (ubound)) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - gfc_add_modify (pblock, ubound, se.expr); - } - } + + gfc_trans_array_cobounds (type, pblock, sym); gfc_trans_vla_type_sizes (sym, pblock); *poffset = offset; @@ -4780,7 +4941,7 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, gcc_assert (GFC_ARRAY_TYPE_P (type)); onstack = TREE_CODE (type) != POINTER_TYPE; - gfc_start_block (&init); + gfc_init_block (&init); /* Evaluate character string length. */ if (sym->ts.type == BT_CHARACTER @@ -5213,6 +5374,8 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, } } + gfc_trans_array_cobounds (type, &init, sym); + /* Set the offset. */ if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL) gfc_add_modify (&init, GFC_TYPE_ARRAY_OFFSET (type), offset); @@ -5725,25 +5888,18 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) if (need_tmp) { - /* Tell the scalarizer to make a temporary. */ - loop.temp_ss = gfc_get_ss (); - loop.temp_ss->type = GFC_SS_TEMP; - loop.temp_ss->next = gfc_ss_terminator; - - if (expr->ts.type == BT_CHARACTER - && !expr->ts.u.cl->backend_decl) + if (expr->ts.type == BT_CHARACTER && !expr->ts.u.cl->backend_decl) get_array_charlen (expr, se); - loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts); - - if (expr->ts.type == BT_CHARACTER) - loop.temp_ss->string_length = expr->ts.u.cl->backend_decl; - else - loop.temp_ss->string_length = NULL; + /* Tell the scalarizer to make a temporary. */ + loop.temp_ss = gfc_get_temp_ss (gfc_typenode_for_spec (&expr->ts), + ((expr->ts.type == BT_CHARACTER) + ? expr->ts.u.cl->backend_decl + : NULL), + loop.dimen); se->string_length = loop.temp_ss->string_length; - loop.temp_ss->data.temp.dimen = loop.dimen; - loop.temp_ss->data.temp.codimen = loop.codimen; + gcc_assert (loop.temp_ss->data.temp.dimen == loop.dimen); gfc_add_ss_to_loop (&loop, loop.temp_ss); } @@ -5787,7 +5943,8 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) lse.string_length = rse.string_length; tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, true, - expr->expr_type == EXPR_VARIABLE, true); + expr->expr_type == EXPR_VARIABLE + || expr->expr_type == EXPR_ARRAY, true); gfc_add_expr_to_block (&block, tmp); /* Finish the copying loops. */ @@ -5815,6 +5972,35 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) tree to; tree base; + ndim = info->ref ? info->ref->u.ar.dimen : info->dimen; + + if (se->want_coarray) + { + gfc_array_ref *ar = &info->ref->u.ar; + + codim = gfc_get_corank (expr); + for (n = 0; n < codim - 1; n++) + { + /* Make sure we are not lost somehow. */ + gcc_assert (ar->dimen_type[n + ndim] == DIMEN_THIS_IMAGE); + + /* Make sure the call to gfc_conv_section_startstride won't + generate unnecessary code to calculate stride. */ + gcc_assert (ar->stride[n + ndim] == NULL); + + gfc_conv_section_startstride (&loop, ss, n + ndim); + loop.from[n + loop.dimen] = info->start[n + ndim]; + loop.to[n + loop.dimen] = info->end[n + ndim]; + } + + gcc_assert (n == codim - 1); + evaluate_bound (&loop.pre, info->start, ar->start, + info->descriptor, n + ndim, true); + loop.from[n + loop.dimen] = info->start[n + ndim]; + } + else + codim = 0; + /* Set the string_length for a character array. */ if (expr->ts.type == BT_CHARACTER) se->string_length = gfc_get_expr_charlen (expr); @@ -5830,9 +6016,8 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) { /* Otherwise make a new one. */ parmtype = gfc_get_element_type (TREE_TYPE (desc)); - parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, - loop.codimen, loop.from, - loop.to, 0, + parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, codim, + loop.from, loop.to, 0, GFC_ARRAY_UNKNOWN, false); parm = gfc_create_var (parmtype, "parm"); } @@ -5862,8 +6047,6 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) else base = NULL_TREE; - ndim = info->ref ? info->ref->u.ar.dimen : info->dimen; - codim = info->codimen; for (n = 0; n < ndim; n++) { stride = gfc_conv_array_stride (desc, n); @@ -5965,24 +6148,15 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) gfc_rank_cst[dim], stride); } - for (n = ndim; n < ndim + codim; n++) + for (n = loop.dimen; n < loop.dimen + codim; n++) { - /* look for the corresponding scalarizer dimension: dim. */ - for (dim = 0; dim < ndim + codim; dim++) - if (info->dim[dim] == n) - break; - - /* loop exited early: the DIM being looked for has been found. */ - gcc_assert (dim < ndim + codim); - - from = loop.from[dim]; - to = loop.to[dim]; + from = loop.from[n]; + to = loop.to[n]; gfc_conv_descriptor_lbound_set (&loop.pre, parm, - gfc_rank_cst[dim], from); - if (n < ndim + codim - 1) + gfc_rank_cst[n], from); + if (n < loop.dimen + codim - 1) gfc_conv_descriptor_ubound_set (&loop.pre, parm, - gfc_rank_cst[dim], to); - dim++; + gfc_rank_cst[n], to); } if (se->data_not_needed) @@ -6459,7 +6633,7 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank, gfc_add_expr_to_block (&block, tmp); } - tmp = built_in_decls[BUILT_IN_MEMCPY]; + tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); tmp = build_call_expr_loc (input_location, tmp, 3, dest, src, size); } @@ -6483,7 +6657,7 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank, /* We know the temporary and the value will be the same length, so can use memcpy. */ - tmp = built_in_decls[BUILT_IN_MEMCPY]; + tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); tmp = build_call_expr_loc (input_location, tmp, 3, gfc_conv_descriptor_data_get (dest), gfc_conv_descriptor_data_get (src), size); @@ -6660,18 +6834,23 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, switch (purpose) { case DEALLOCATE_ALLOC_COMP: - if (c->attr.allocatable && c->attr.dimension) + if (cmp_has_alloc_comps && !c->attr.pointer) + { + /* Do not deallocate the components of ultimate pointer + components. */ + comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, + decl, cdecl, NULL_TREE); + rank = c->as ? c->as->rank : 0; + tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE, + rank, purpose); + gfc_add_expr_to_block (&fnblock, tmp); + } + + if (c->attr.allocatable + && (c->attr.dimension || c->attr.codimension)) { comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); - if (cmp_has_alloc_comps && !c->attr.pointer) - { - /* Do not deallocate the components of ultimate pointer - components. */ - tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE, - c->as->rank, purpose); - gfc_add_expr_to_block (&fnblock, tmp); - } tmp = gfc_trans_dealloc_allocated (comp); gfc_add_expr_to_block (&fnblock, tmp); } @@ -6715,7 +6894,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, case NULLIFY_ALLOC_COMP: if (c->attr.pointer) continue; - else if (c->attr.allocatable && c->attr.dimension) + else if (c->attr.allocatable + && (c->attr.dimension|| c->attr.codimension)) { comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); @@ -7233,7 +7413,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, in the array reference - (*desc.data)[]. */ gfc_init_block (&realloc_block); tmp = build_call_expr_loc (input_location, - built_in_decls[BUILT_IN_REALLOC], 2, + builtin_decl_explicit (BUILT_IN_REALLOC), 2, fold_convert (pvoid_type_node, array1), size2); gfc_conv_descriptor_data_set (&realloc_block, @@ -7249,8 +7429,8 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, /* Malloc expression. */ gfc_init_block (&alloc_block); tmp = build_call_expr_loc (input_location, - built_in_decls[BUILT_IN_MALLOC], 1, - size2); + builtin_decl_explicit (BUILT_IN_MALLOC), + 1, size2); gfc_conv_descriptor_data_set (&alloc_block, desc, tmp); tmp = gfc_conv_descriptor_dtype (desc); @@ -7391,7 +7571,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) gfc_add_expr_to_block (&cleanup, tmp); } - if (sym->attr.allocatable && sym->attr.dimension + if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension) && !sym->attr.save && !sym->attr.result) { tmp = gfc_trans_dealloc_allocated (sym->backend_decl); @@ -7421,29 +7601,28 @@ static gfc_ss * gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr) { gfc_ref *ref; - gfc_array_ref *ar; - gfc_ss *newss; - int n; for (ref = expr->ref; ref; ref = ref->next) if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT) break; + return gfc_walk_array_ref (ss, expr, ref); +} + + +gfc_ss * +gfc_walk_array_ref (gfc_ss * ss, gfc_expr * expr, gfc_ref * ref) +{ + gfc_array_ref *ar; + gfc_ss *newss; + int n; + for (; ref; ref = ref->next) { if (ref->type == REF_SUBSTRING) { - newss = gfc_get_ss (); - newss->type = GFC_SS_SCALAR; - newss->expr = ref->u.ss.start; - newss->next = ss; - ss = newss; - - newss = gfc_get_ss (); - newss->type = GFC_SS_SCALAR; - newss->expr = ref->u.ss.end; - newss->next = ss; - ss = newss; + ss = gfc_get_scalar_ss (ss, ref->u.ss.start); + ss = gfc_get_scalar_ss (ss, ref->u.ss.end); } /* We're only interested in array sections from now on. */ @@ -7452,83 +7631,46 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr) ar = &ref->u.ar; - if (ar->as->rank == 0 && ref->next != NULL) - { - /* Scalar coarray. */ - continue; - } - switch (ar->type) { case AR_ELEMENT: - for (n = 0; n < ar->dimen + ar->codimen; n++) - { - newss = gfc_get_ss (); - newss->type = GFC_SS_SCALAR; - newss->expr = ar->start[n]; - newss->next = ss; - ss = newss; - } + for (n = ar->dimen + ar->codimen - 1; n >= 0; n--) + ss = gfc_get_scalar_ss (ss, ar->start[n]); break; case AR_FULL: - newss = gfc_get_ss (); - newss->type = GFC_SS_SECTION; - newss->expr = expr; - newss->next = ss; - newss->data.info.dimen = ar->as->rank; - newss->data.info.codimen = 0; + newss = gfc_get_array_ss (ss, expr, ar->as->rank, GFC_SS_SECTION); newss->data.info.ref = ref; /* Make sure array is the same as array(:,:), this way we don't need to special case all the time. */ ar->dimen = ar->as->rank; - ar->codimen = 0; for (n = 0; n < ar->dimen; n++) { - newss->data.info.dim[n] = n; ar->dimen_type[n] = DIMEN_RANGE; gcc_assert (ar->start[n] == NULL); gcc_assert (ar->end[n] == NULL); gcc_assert (ar->stride[n] == NULL); } - for (n = ar->dimen; n < ar->dimen + ar->as->corank; n++) - { - newss->data.info.dim[n] = n; - ar->dimen_type[n] = DIMEN_RANGE; - - gcc_assert (ar->start[n] == NULL); - gcc_assert (ar->end[n] == NULL); - } ss = newss; break; case AR_SECTION: - newss = gfc_get_ss (); - newss->type = GFC_SS_SECTION; - newss->expr = expr; - newss->next = ss; - newss->data.info.dimen = 0; - newss->data.info.codimen = 0; + newss = gfc_get_array_ss (ss, expr, 0, GFC_SS_SECTION); newss->data.info.ref = ref; - /* We add SS chains for all the subscripts in the section. */ - for (n = 0; n < ar->dimen + ar->codimen; n++) + /* We add SS chains for all the subscripts in the section. */ + for (n = 0; n < ar->dimen; n++) { gfc_ss *indexss; switch (ar->dimen_type[n]) { - case DIMEN_THIS_IMAGE: - continue; case DIMEN_ELEMENT: /* Add SS for elemental (scalar) subscripts. */ gcc_assert (ar->start[n]); - indexss = gfc_get_ss (); - indexss->type = GFC_SS_SCALAR; - indexss->expr = ar->start[n]; - indexss->next = gfc_ss_terminator; + indexss = gfc_get_scalar_ss (gfc_ss_terminator, ar->start[n]); indexss->loop_chain = gfc_ss_terminator; newss->data.info.subscript[n] = indexss; break; @@ -7536,25 +7678,19 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr) case DIMEN_RANGE: /* We don't add anything for sections, just remember this dimension for later. */ - newss->data.info.dim[newss->data.info.dimen - + newss->data.info.codimen] = n; - if (n < ar->dimen) - newss->data.info.dimen++; + newss->data.info.dim[newss->data.info.dimen] = n; + newss->data.info.dimen++; break; case DIMEN_VECTOR: /* Create a GFC_SS_VECTOR index in which we can store the vector's descriptor. */ - indexss = gfc_get_ss (); - indexss->type = GFC_SS_VECTOR; - indexss->expr = ar->start[n]; - indexss->next = gfc_ss_terminator; + indexss = gfc_get_array_ss (gfc_ss_terminator, ar->start[n], + 1, GFC_SS_VECTOR); indexss->loop_chain = gfc_ss_terminator; newss->data.info.subscript[n] = indexss; - newss->data.info.dim[newss->data.info.dimen - + newss->data.info.codimen] = n; - if (n < ar->dimen) - newss->data.info.dimen++; + newss->data.info.dim[newss->data.info.dimen] = n; + newss->data.info.dimen++; break; default: @@ -7562,8 +7698,10 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr) gcc_unreachable (); } } - /* We should have at least one non-elemental dimension. */ - gcc_assert (newss->data.info.dimen > 0); + /* We should have at least one non-elemental dimension, + unless we are creating a descriptor for a (scalar) coarray. */ + gcc_assert (newss->data.info.dimen > 0 + || newss->data.info.ref->u.ar.as->corank > 0); ss = newss; break; @@ -7585,7 +7723,6 @@ gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr) { gfc_ss *head; gfc_ss *head2; - gfc_ss *newss; head = gfc_walk_subexpr (ss, expr->value.op.op1); if (expr->value.op.op2 == NULL) @@ -7603,8 +7740,6 @@ gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr) /* One of the operands needs scalarization, the other is scalar. Create a gfc_ss for the scalar expression. */ - newss = gfc_get_ss (); - newss->type = GFC_SS_SCALAR; if (head == ss) { /* First operand is scalar. We build the chain in reverse order, so @@ -7614,17 +7749,13 @@ gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr) head = head->next; /* Check we haven't somehow broken the chain. */ gcc_assert (head); - newss->next = ss; - head->next = newss; - newss->expr = expr->value.op.op1; + head->next = gfc_get_scalar_ss (ss, expr->value.op.op1); } else /* head2 == head */ { gcc_assert (head2 == head); /* Second operand is scalar. */ - newss->next = head2; - head2 = newss; - newss->expr = expr->value.op.op2; + head2 = gfc_get_scalar_ss (head2, expr->value.op.op2); } return head2; @@ -7679,10 +7810,9 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, if (newss == head) { /* Scalar argument. */ - newss = gfc_get_ss (); + gcc_assert (type == GFC_SS_SCALAR || type == GFC_SS_REFERENCE); + newss = gfc_get_scalar_ss (head, arg->expr); newss->type = type; - newss->expr = arg->expr; - newss->next = head; } else scalar = 0; @@ -7719,11 +7849,9 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, static gfc_ss * gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr) { - gfc_ss *newss; gfc_intrinsic_sym *isym; gfc_symbol *sym; gfc_component *comp = NULL; - int n; isym = expr->value.function.isym; @@ -7739,16 +7867,7 @@ gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr) gfc_is_proc_ptr_comp (expr, &comp); if ((!comp && gfc_return_by_reference (sym) && sym->result->attr.dimension) || (comp && comp->attr.dimension)) - { - newss = gfc_get_ss (); - newss->type = GFC_SS_FUNCTION; - newss->expr = expr; - newss->next = ss; - newss->data.info.dimen = expr->rank; - for (n = 0; n < newss->data.info.dimen; n++) - newss->data.info.dim[n] = n; - return newss; - } + return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION); /* Walk the parameters of an elemental function. For now we always pass by reference. */ @@ -7767,18 +7886,7 @@ gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr) static gfc_ss * gfc_walk_array_constructor (gfc_ss * ss, gfc_expr * expr) { - gfc_ss *newss; - int n; - - newss = gfc_get_ss (); - newss->type = GFC_SS_CONSTRUCTOR; - newss->expr = expr; - newss->next = ss; - newss->data.info.dimen = expr->rank; - for (n = 0; n < expr->rank; n++) - newss->data.info.dim[n] = n; - - return newss; + return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_CONSTRUCTOR); }