diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/fortran/ChangeLog | 35 | ||||
| -rw-r--r-- | gcc/fortran/Make-lang.in | 2 | ||||
| -rw-r--r-- | gcc/fortran/dependency.c | 68 | ||||
| -rw-r--r-- | gcc/fortran/dependency.h | 1 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.c | 376 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.c | 5 | ||||
| -rw-r--r-- | gcc/fortran/trans.h | 4 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 6 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/vector_subscript_1.f90 | 174 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/vector_subscript_2.f90 | 39 |
10 files changed, 463 insertions, 247 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 22e74ef..5b592e7 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,5 +1,40 @@ 2005-09-09 Richard Sandiford <richard@codesourcery.com> + PR fortran/19239 + * Makefile.in (fortran/trans-expr.o): Depend on dependency.h. + * dependency.h (gfc_ref_needs_temporary_p): Declare. + * dependency.c (gfc_ref_needs_temporary_p): New function. + (gfc_check_fncall_dependency): Use it instead of inlined check. + By so doing, take advantage of the fact that character substrings + within an array reference also need a temporary. + * trans.h (GFC_SS_VECTOR): Adjust comment. + * trans-array.c (gfc_free_ss): Remove GFC_SS_VECTOR case. + (gfc_set_vector_loop_bounds): New function. + (gfc_add_loop_ss_code): Call it after evaluating the subscripts of + a GFC_SS_SECTION. Deal with the GFC_SS_VECTOR case by evaluating + the vector expression and caching its descriptor for use within + the loop. + (gfc_conv_array_index_ref, gfc_conv_vector_array_index): Delete. + (gfc_conv_array_index_offset): Handle scalar, vector and range + dimensions as separate cases of a switch statement. In the vector + case, use the loop variable to calculate a vector index and use the + referenced element as the dimension's index. Perform bounds checking + on this final index. + (gfc_conv_section_upper_bound): Return null for vector indexes. + (gfc_conv_section_startstride): Give vector indexes a start value + of 0 and a stride of 1. + (gfc_conv_ss_startstride): Adjust for new GFC_SS_VECTOR representation. + (gfc_conv_expr_descriptor): Expand comments. Generalize the + handling of the !want_pointer && !direct_byref case. Use + gfc_ref_needs_temporary_p to decide whether the variable case + needs a temporary. + (gfc_walk_variable_expr): Handle DIMEN_VECTOR by creating a + GFC_SS_VECTOR index. + * trans-expr.c: Include dependency.h. + (gfc_trans_arrayfunc_assign): Fail if the target needs a temporary. + +2005-09-09 Richard Sandiford <richard@codesourcery.com> + PR fortran/21104 * trans.h (gfc_interface_sym_mapping, gfc_interface_mapping): Moved from trans-expr.c. diff --git a/gcc/fortran/Make-lang.in b/gcc/fortran/Make-lang.in index 6f9ac61..184ac6b 100644 --- a/gcc/fortran/Make-lang.in +++ b/gcc/fortran/Make-lang.in @@ -289,7 +289,7 @@ fortran/trans-decl.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-decl.h \ fortran/trans-types.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-types.h \ real.h toplev.h $(TARGET_H) fortran/trans-const.o: $(GFORTRAN_TRANS_DEPS) -fortran/trans-expr.o: $(GFORTRAN_TRANS_DEPS) +fortran/trans-expr.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h fortran/trans-stmt.o: $(GFORTRAN_TRANS_DEPS) fortran/trans-io.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-io.h fortran/trans-array.o: $(GFORTRAN_TRANS_DEPS) diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c index 5b0045e..9c6b4f6 100644 --- a/gcc/fortran/dependency.c +++ b/gcc/fortran/dependency.c @@ -175,6 +175,45 @@ gfc_is_same_range (gfc_array_ref * ar1, gfc_array_ref * ar2, int n, int def) } +/* Return true if the result of reference REF can only be constructed + using a temporary array. */ + +bool +gfc_ref_needs_temporary_p (gfc_ref *ref) +{ + int n; + bool subarray_p; + + subarray_p = false; + for (; ref; ref = ref->next) + switch (ref->type) + { + case REF_ARRAY: + /* Vector dimensions are generally not monotonic and must be + handled using a temporary. */ + if (ref->u.ar.type == AR_SECTION) + for (n = 0; n < ref->u.ar.dimen; n++) + if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR) + return true; + + subarray_p = true; + break; + + case REF_SUBSTRING: + /* Within an array reference, character substrings generally + need a temporary. Character array strides are expressed as + multiples of the element size (consistent with other array + types), not in characters. */ + return subarray_p; + + case REF_COMPONENT: + break; + } + + return false; +} + + /* Dependency checking for direct function return by reference. Returns true if the arguments of the function depend on the destination. This is considerably less conservative than other @@ -185,9 +224,7 @@ int gfc_check_fncall_dependency (gfc_expr * dest, gfc_expr * fncall) { gfc_actual_arglist *actual; - gfc_ref *ref; gfc_expr *expr; - int n; gcc_assert (dest->expr_type == EXPR_VARIABLE && fncall->expr_type == EXPR_FUNCTION); @@ -205,31 +242,8 @@ gfc_check_fncall_dependency (gfc_expr * dest, gfc_expr * fncall) switch (expr->expr_type) { case EXPR_VARIABLE: - if (expr->rank > 1) - { - /* This is an array section. */ - for (ref = expr->ref; ref; ref = ref->next) - { - if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT) - break; - } - gcc_assert (ref); - /* AR_FULL can't contain vector subscripts. */ - if (ref->u.ar.type == AR_SECTION) - { - for (n = 0; n < ref->u.ar.dimen; n++) - { - if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR) - break; - } - /* Vector subscript array sections will be copied to a - temporary. */ - if (n != ref->u.ar.dimen) - continue; - } - } - - if (gfc_check_dependency (dest, actual->expr, NULL, 0)) + if (!gfc_ref_needs_temporary_p (expr->ref) + && gfc_check_dependency (dest, expr, NULL, 0)) return 1; break; diff --git a/gcc/fortran/dependency.h b/gcc/fortran/dependency.h index dafb7fc..c4fe493 100644 --- a/gcc/fortran/dependency.h +++ b/gcc/fortran/dependency.h @@ -21,6 +21,7 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA +bool gfc_ref_needs_temporary_p (gfc_ref *); int gfc_check_fncall_dependency (gfc_expr *, gfc_expr *); int gfc_check_dependency (gfc_expr *, gfc_expr *, gfc_expr **, int); int gfc_is_same_range (gfc_array_ref *, gfc_array_ref *, int, int); diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 4eac13d..552bae6 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -361,7 +361,6 @@ gfc_free_ss (gfc_ss * ss) switch (ss->type) { case GFC_SS_SECTION: - case GFC_SS_VECTOR: for (n = 0; n < GFC_MAX_DIMENSIONS; n++) { if (ss->data.info.subscript[n]) @@ -1355,6 +1354,47 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss) } +/* INFO describes a GFC_SS_SECTION in loop LOOP, and this function is + called after evaluating all of INFO's vector dimensions. Go through + each such vector dimension and see if we can now fill in any missing + loop bounds. */ + +static void +gfc_set_vector_loop_bounds (gfc_loopinfo * loop, gfc_ss_info * info) +{ + gfc_se se; + tree tmp; + tree desc; + tree zero; + int n; + int dim; + + for (n = 0; n < loop->dimen; n++) + { + dim = info->dim[n]; + if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR + && loop->to[n] == NULL) + { + /* Loop variable N indexes vector dimension DIM, and we don't + yet know the upper bound of loop variable N. Set it to the + difference between the vector's upper and lower bounds. */ + gcc_assert (loop->from[n] == gfc_index_zero_node); + gcc_assert (info->subscript[dim] + && info->subscript[dim]->type == GFC_SS_VECTOR); + + gfc_init_se (&se, NULL); + desc = info->subscript[dim]->data.info.descriptor; + zero = gfc_rank_cst[0]; + tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, + gfc_conv_descriptor_ubound (desc, zero), + gfc_conv_descriptor_lbound (desc, zero)); + tmp = gfc_evaluate_now (tmp, &loop->pre); + loop->to[n] = tmp; + } + } +} + + /* Add the pre and post chains for all the scalar expressions in a SS chain to loop. This is called after the loop parameters have been calculated, but before the actual scalarizing loops. */ @@ -1410,14 +1450,21 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript) break; case GFC_SS_SECTION: - case GFC_SS_VECTOR: - /* Scalarized expression. Evaluate any scalar subscripts. */ + /* Add the expressions for scalar and vector subscripts. */ for (n = 0; n < GFC_MAX_DIMENSIONS; n++) - { - /* Add the expressions for scalar subscripts. */ - if (ss->data.info.subscript[n]) - gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true); - } + if (ss->data.info.subscript[n]) + gfc_add_loop_ss_code (loop, ss->data.info.subscript[n], true); + + gfc_set_vector_loop_bounds (loop, &ss->data.info); + break; + + case GFC_SS_VECTOR: + /* Get the vector's descriptor and store it in SS. */ + gfc_init_se (&se, NULL); + gfc_conv_expr_descriptor (&se, ss->expr, gfc_walk_expr (ss->expr)); + gfc_add_block_to_block (&loop->pre, &se.pre); + gfc_add_block_to_block (&loop->post, &se.post); + ss->data.info.descriptor = se.expr; break; case GFC_SS_INTRINSIC: @@ -1620,41 +1667,6 @@ gfc_conv_array_ubound (tree descriptor, int dim) } -/* Translate an array reference. The descriptor should be in se->expr. - Do not use this function, it wil be removed soon. */ -/*GCC ARRAYS*/ - -static void -gfc_conv_array_index_ref (gfc_se * se, tree pointer, tree * indices, - tree offset, int dimen) -{ - tree array; - tree tmp; - tree index; - int n; - - array = gfc_build_indirect_ref (pointer); - - index = offset; - for (n = 0; n < dimen; n++) - { - /* index = index + stride[n]*indices[n] */ - tmp = gfc_conv_array_stride (se->expr, n); - tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, indices[n], tmp); - - index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, tmp); - } - - /* Result = data[index]. */ - tmp = gfc_build_array_ref (array, index); - - /* Check we've used the correct number of dimensions. */ - gcc_assert (TREE_CODE (TREE_TYPE (tmp)) != ARRAY_TYPE); - - se->expr = tmp; -} - - /* Generate code to perform an array index bound check. */ static tree @@ -1682,61 +1694,6 @@ gfc_trans_array_bound_check (gfc_se * se, tree descriptor, tree index, int n) } -/* A reference to an array vector subscript. Uses recursion to handle nested - vector subscripts. */ - -static tree -gfc_conv_vector_array_index (gfc_se * se, tree index, gfc_ss * ss) -{ - tree descsave; - tree indices[GFC_MAX_DIMENSIONS]; - gfc_array_ref *ar; - gfc_ss_info *info; - int n; - - gcc_assert (ss && ss->type == GFC_SS_VECTOR); - - /* Save the descriptor. */ - descsave = se->expr; - info = &ss->data.info; - se->expr = info->descriptor; - - ar = &info->ref->u.ar; - for (n = 0; n < ar->dimen; n++) - { - switch (ar->dimen_type[n]) - { - case DIMEN_ELEMENT: - gcc_assert (info->subscript[n] != gfc_ss_terminator - && info->subscript[n]->type == GFC_SS_SCALAR); - indices[n] = info->subscript[n]->data.scalar.expr; - break; - - case DIMEN_RANGE: - indices[n] = index; - break; - - case DIMEN_VECTOR: - index = gfc_conv_vector_array_index (se, index, info->subscript[n]); - - indices[n] = - gfc_trans_array_bound_check (se, info->descriptor, index, n); - break; - - default: - gcc_unreachable (); - } - } - /* Get the index from the vector. */ - gfc_conv_array_index_ref (se, info->data, indices, info->offset, ar->dimen); - index = se->expr; - /* Put the descriptor back. */ - se->expr = descsave; - - return index; -} - - /* Return the offset for an index. Performs bound checking for elemental dimensions. Single element references are processed separately. */ @@ -1745,25 +1702,52 @@ gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i, gfc_array_ref * ar, tree stride) { tree index; + tree desc; + tree data; /* Get the index into the array for this dimension. */ if (ar) { gcc_assert (ar->type != AR_ELEMENT); - if (ar->dimen_type[dim] == DIMEN_ELEMENT) + switch (ar->dimen_type[dim]) { + case DIMEN_ELEMENT: gcc_assert (i == -1); /* Elemental dimension. */ gcc_assert (info->subscript[dim] - && info->subscript[dim]->type == GFC_SS_SCALAR); + && info->subscript[dim]->type == GFC_SS_SCALAR); /* We've already translated this value outside the loop. */ index = info->subscript[dim]->data.scalar.expr; index = gfc_trans_array_bound_check (se, info->descriptor, index, dim); - } - else - { + break; + + case DIMEN_VECTOR: + gcc_assert (info && se->loop); + gcc_assert (info->subscript[dim] + && info->subscript[dim]->type == GFC_SS_VECTOR); + desc = info->subscript[dim]->data.info.descriptor; + + /* Get a zero-based index into the vector. */ + index = fold_build2 (MINUS_EXPR, gfc_array_index_type, + se->loop->loopvar[i], se->loop->from[i]); + + /* Multiply the index by the stride. */ + index = fold_build2 (MULT_EXPR, gfc_array_index_type, + index, gfc_conv_array_stride (desc, 0)); + + /* Read the vector to get an index into info->descriptor. */ + data = gfc_build_indirect_ref (gfc_conv_array_data (desc)); + index = gfc_build_array_ref (data, index); + index = gfc_evaluate_now (index, &se->pre); + + /* Do any bounds checking on the final info->descriptor index. */ + index = gfc_trans_array_bound_check (se, info->descriptor, + index, dim); + break; + + case DIMEN_RANGE: /* Scalarized dimension. */ gcc_assert (info && se->loop); @@ -1773,18 +1757,10 @@ gfc_conv_array_index_offset (gfc_se * se, gfc_ss_info * info, int dim, int i, info->stride[i]); index = fold_build2 (PLUS_EXPR, gfc_array_index_type, index, info->delta[i]); + break; - if (ar->dimen_type[dim] == DIMEN_VECTOR) - { - /* Handle vector subscripts. */ - index = gfc_conv_vector_array_index (se, index, - info->subscript[dim]); - index = - gfc_trans_array_bound_check (se, info->descriptor, index, - dim); - } - else - gcc_assert (ar->dimen_type[dim] == DIMEN_RANGE); + default: + gcc_unreachable (); } } else @@ -2195,27 +2171,25 @@ static tree gfc_conv_section_upper_bound (gfc_ss * ss, int n, stmtblock_t * pblock) { int dim; - gfc_ss *vecss; gfc_expr *end; tree desc; tree bound; gfc_se se; + gfc_ss_info *info; gcc_assert (ss->type == GFC_SS_SECTION); - /* For vector array subscripts we want the size of the vector. */ - dim = ss->data.info.dim[n]; - vecss = ss; - while (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_VECTOR) - { - vecss = vecss->data.info.subscript[dim]; - gcc_assert (vecss && vecss->type == GFC_SS_VECTOR); - dim = vecss->data.info.dim[0]; - } + info = &ss->data.info; + dim = info->dim[n]; - gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_RANGE); - end = vecss->data.info.ref->u.ar.end[dim]; - desc = vecss->data.info.descriptor; + 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) { @@ -2242,32 +2216,28 @@ gfc_conv_section_startstride (gfc_loopinfo * loop, gfc_ss * ss, int n) { gfc_expr *start; gfc_expr *stride; - gfc_ss *vecss; tree desc; gfc_se se; gfc_ss_info *info; int dim; - info = &ss->data.info; + gcc_assert (ss->type == GFC_SS_SECTION); + info = &ss->data.info; dim = info->dim[n]; - /* For vector array subscripts we want the size of the vector. */ - vecss = ss; - while (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_VECTOR) + if (info->ref->u.ar.dimen_type[dim] == DIMEN_VECTOR) { - vecss = vecss->data.info.subscript[dim]; - gcc_assert (vecss && vecss->type == GFC_SS_VECTOR); - /* Get the descriptors for the vector subscripts as well. */ - if (!vecss->data.info.descriptor) - gfc_conv_ss_descriptor (&loop->pre, vecss, !loop->array_parameter); - dim = vecss->data.info.dim[0]; + /* We use a zero-based index to access the vector. */ + info->start[n] = gfc_index_zero_node; + info->stride[n] = gfc_index_one_node; + return; } - gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim] == DIMEN_RANGE); - start = vecss->data.info.ref->u.ar.start[dim]; - stride = vecss->data.info.ref->u.ar.stride[dim]; - desc = vecss->data.info.descriptor; + gcc_assert (info->ref->u.ar.dimen_type[dim] == DIMEN_RANGE); + desc = info->descriptor; + start = info->ref->u.ar.start[dim]; + stride = info->ref->u.ar.stride[dim]; /* Calculate the start of the range. For vector subscripts this will be the range of the vector. */ @@ -2309,7 +2279,6 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) int n; tree tmp; gfc_ss *ss; - gfc_ss *vecss; tree desc; loop->dimen = 0; @@ -2390,22 +2359,15 @@ gfc_conv_ss_startstride (gfc_loopinfo * loop) /* TODO: range checking for mapped dimensions. */ info = &ss->data.info; - /* This only checks scalarized dimensions, elemental dimensions are - checked later. */ + /* This code only checks ranges. Elemental and vector + dimensions are checked later. */ for (n = 0; n < loop->dimen; n++) { dim = info->dim[n]; - vecss = ss; - while (vecss->data.info.ref->u.ar.dimen_type[dim] - == DIMEN_VECTOR) - { - vecss = vecss->data.info.subscript[dim]; - gcc_assert (vecss && vecss->type == GFC_SS_VECTOR); - dim = vecss->data.info.dim[0]; - } - gcc_assert (vecss->data.info.ref->u.ar.dimen_type[dim] - == DIMEN_RANGE); - desc = vecss->data.info.descriptor; + if (info->ref->u.ar.dimen_type[dim] != DIMEN_RANGE) + continue; + + desc = ss->data.info.descriptor; /* Check lower bound. */ bound = gfc_conv_array_lbound (desc, dim); @@ -3662,11 +3624,28 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body) } -/* Convert an array for passing as an actual parameter. Expressions and +/* Convert an array for passing as an actual argument. Expressions and vector subscripts are evaluated and stored in a temporary, which is then passed. For whole arrays the descriptor is passed. For array sections a modified copy of the descriptor is passed, but using the original data. - Also used for array pointer assignments by setting se->direct_byref. */ + + This function is also used for array pointer assignments, and there + are three cases: + + - want_pointer && !se->direct_byref + EXPR is an actual argument. On exit, se->expr contains a + pointer to the array descriptor. + + - !want_pointer && !se->direct_byref + EXPR is an actual argument to an intrinsic function or the + left-hand side of a pointer assignment. On exit, se->expr + contains the descriptor for EXPR. + + - !want_pointer && se->direct_byref + EXPR is the right-hand side of a pointer assignment and + se->expr is the descriptor for the previously-evaluated + left-hand side. The function creates an assignment from + EXPR to se->expr. */ void gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) @@ -3682,7 +3661,6 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) tree start; tree offset; int full; - gfc_ss *vss; gfc_ref *ref; gcc_assert (ss != gfc_ss_terminator); @@ -3701,21 +3679,16 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) secss = secss->next; gcc_assert (secss != gfc_ss_terminator); - - need_tmp = 0; - for (n = 0; n < secss->data.info.dimen; n++) - { - vss = secss->data.info.subscript[secss->data.info.dim[n]]; - if (vss && vss->type == GFC_SS_VECTOR) - need_tmp = 1; - } - info = &secss->data.info; /* Get the descriptor for the array. */ gfc_conv_ss_descriptor (&se->pre, secss, 0); desc = info->descriptor; - if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) + + need_tmp = gfc_ref_needs_temporary_p (expr->ref); + if (need_tmp) + full = 0; + else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc))) { /* Create a new descriptor if the array doesn't have one. */ full = 0; @@ -3745,23 +3718,6 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) } } - /* Check for substring references. */ - ref = expr->ref; - if (!need_tmp && ref && expr->ts.type == BT_CHARACTER) - { - while (ref->next) - ref = ref->next; - if (ref->type == REF_SUBSTRING) - { - /* In general character substrings need a copy. Character - array strides are expressed as multiples of the element - size (consistent with other array types), not in - characters. */ - full = 0; - need_tmp = 1; - } - } - if (full) { if (se->direct_byref) @@ -3841,7 +3797,8 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) if (!need_tmp) loop.array_parameter = 1; else - gcc_assert (se->want_pointer && !se->direct_byref); + /* The right-hand side of a pointer assignment mustn't use a temporary. */ + gcc_assert (!se->direct_byref); /* Setup the scalarizing loops and bounds. */ gfc_conv_ss_startstride (&loop); @@ -3922,17 +3879,11 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node); gcc_assert (is_gimple_lvalue (desc)); - se->expr = gfc_build_addr_expr (NULL, desc); } else if (expr->expr_type == EXPR_FUNCTION) { desc = info->descriptor; - if (se->want_pointer) - se->expr = gfc_build_addr_expr (NULL_TREE, desc); - else - se->expr = desc; - if (expr->ts.type == BT_CHARACTER) se->string_length = expr->symtree->n.sym->ts.cl->backend_decl; } @@ -4083,15 +4034,16 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss) tmp = gfc_conv_descriptor_offset (parm); gfc_add_modify_expr (&loop.pre, tmp, gfc_index_zero_node); } + desc = parm; + } - if (!se->direct_byref) - { - /* Get a pointer to the new descriptor. */ - if (se->want_pointer) - se->expr = gfc_build_addr_expr (NULL, parm); - else - se->expr = parm; - } + if (!se->direct_byref) + { + /* Get a pointer to the new descriptor. */ + if (se->want_pointer) + se->expr = gfc_build_addr_expr (NULL, desc); + else + se->expr = desc; } gfc_add_block_to_block (&se->pre, &loop.pre); @@ -4383,24 +4335,14 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr) break; case DIMEN_VECTOR: - /* Get a SS for the vector. This will not be added to the - chain directly. */ - indexss = gfc_walk_expr (ar->start[n]); - if (indexss == gfc_ss_terminator) - internal_error ("scalar vector subscript???"); - - /* We currently only handle really simple vector - subscripts. */ - if (indexss->next != gfc_ss_terminator) - gfc_todo_error ("vector subscript expressions"); - indexss->loop_chain = gfc_ss_terminator; - - /* Mark this as a vector subscript. We don't add this - directly into the chain, but as a subscript of the - existing SS for this term. */ + /* 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->loop_chain = gfc_ss_terminator; newss->data.info.subscript[n] = indexss; - /* Also remember this dimension. */ newss->data.info.dim[newss->data.info.dimen] = n; newss->data.info.dimen++; break; diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index ceabb57..fce8e7b 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -39,6 +39,7 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA #include "trans-array.h" /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */ #include "trans-stmt.h" +#include "dependency.h" static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr); static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *, @@ -2575,6 +2576,10 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) if (expr2->symtree->n.sym->attr.elemental) return NULL; + /* Fail if EXPR1 can't be expressed as a descriptor. */ + if (gfc_ref_needs_temporary_p (expr1->ref)) + return NULL; + /* Check for a dependency. */ if (gfc_check_fncall_dependency (expr1, expr2)) return NULL; diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index e2f2526..a0b4334 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -138,8 +138,8 @@ typedef enum uses this temporary inside the scalarization loop. */ GFC_SS_CONSTRUCTOR, - /* A vector subscript. Only used as the SS chain for a subscript. - Similar int format to a GFC_SS_SECTION. */ + /* A vector subscript. The vector's descriptor is cached in the + "descriptor" field of the associated gfc_ss_info. */ GFC_SS_VECTOR, /* A temporary array allocated by the scalarizer. Its rank can be less diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 6050440..6ce489e 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,5 +1,11 @@ 2005-09-09 Richard Sandiford <richard@codesourcery.com> + PR fortran/19239 + * gfortran.fortran-torture/execute/pr19239-1.f90, + * gfortran.fortran-torture/execute/pr19239-2.f90: New tests + +2005-09-09 Richard Sandiford <richard@codesourcery.com> + PR fortran/21104 * gfortran.dg/array_alloc_1.f90, * gfortran.dg/array_alloc_2.f90, diff --git a/gcc/testsuite/gfortran.dg/vector_subscript_1.f90 b/gcc/testsuite/gfortran.dg/vector_subscript_1.f90 new file mode 100644 index 0000000..dd09fbb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/vector_subscript_1.f90 @@ -0,0 +1,174 @@ +! PR 19239. Check for various kinds of vector subscript. In this test, +! all vector subscripts are indexing single-dimensional arrays. +! { dg-do run } +program main + implicit none + integer, parameter :: n = 10 + integer :: i, j, calls + integer, dimension (n) :: a, b, idx, id + + idx = (/ 3, 1, 5, 2, 4, 10, 8, 7, 6, 9 /) + id = (/ (i, i = 1, n) /) + b = (/ (i * 100, i = 1, n) /) + + !------------------------------------------------------------------ + ! Tests for a simple variable subscript + !------------------------------------------------------------------ + + a (idx) = b + call test (idx, id) + + a = b (idx) + call test (id, idx) + + a (idx) = b (idx) + call test (idx, idx) + + !------------------------------------------------------------------ + ! Tests for constant ranges with non-default stride + !------------------------------------------------------------------ + + a (idx (1:7:3)) = b (10:6:-2) + call test (idx (1:7:3), id (10:6:-2)) + + a (10:6:-2) = b (idx (1:7:3)) + call test (id (10:6:-2), idx (1:7:3)) + + a (idx (1:7:3)) = b (idx (1:7:3)) + call test (idx (1:7:3), idx (1:7:3)) + + a (idx (1:7:3)) = b (idx (10:6:-2)) + call test (idx (1:7:3), idx (10:6:-2)) + + a (idx (10:6:-2)) = b (idx (10:6:-2)) + call test (idx (10:6:-2), idx (10:6:-2)) + + a (idx (10:6:-2)) = b (idx (1:7:3)) + call test (idx (10:6:-2), idx (1:7:3)) + + !------------------------------------------------------------------ + ! Tests for subscripts of the form CONSTRANGE + CONST + !------------------------------------------------------------------ + + a (idx (1:5) + 1) = b (1:5) + call test (idx (1:5) + 1, id (1:5)) + + a (1:5) = b (idx (1:5) + 1) + call test (id (1:5), idx (1:5) + 1) + + a (idx (6:10) - 1) = b (idx (1:5) + 1) + call test (idx (6:10) - 1, idx (1:5) + 1) + + !------------------------------------------------------------------ + ! Tests for variable subranges + !------------------------------------------------------------------ + + do j = 5, 10 + a (idx (2:j:2)) = b (3:2+j/2) + call test (idx (2:j:2), id (3:2+j/2)) + + a (3:2+j/2) = b (idx (2:j:2)) + call test (id (3:2+j/2), idx (2:j:2)) + + a (idx (2:j:2)) = b (idx (2:j:2)) + call test (idx (2:j:2), idx (2:j:2)) + end do + + !------------------------------------------------------------------ + ! Tests for function vectors + !------------------------------------------------------------------ + + calls = 0 + + a (foo (5, calls)) = b (2:10:2) + call test (foo (5, calls), id (2:10:2)) + + a (2:10:2) = b (foo (5, calls)) + call test (id (2:10:2), foo (5, calls)) + + a (foo (5, calls)) = b (foo (5, calls)) + call test (foo (5, calls), foo (5, calls)) + + if (calls .ne. 8) call abort + + !------------------------------------------------------------------ + ! Tests for constant vector constructors + !------------------------------------------------------------------ + + a ((/ 1, 5, 3, 9 /)) = b (1:4) + call test ((/ 1, 5, 3, 9 /), id (1:4)) + + a (1:4) = b ((/ 1, 5, 3, 9 /)) + call test (id (1:4), (/ 1, 5, 3, 9 /)) + + a ((/ 1, 5, 3, 9 /)) = b ((/ 2, 5, 3, 7 /)) + call test ((/ 1, 5, 3, 9 /), (/ 2, 5, 3, 7 /)) + + !------------------------------------------------------------------ + ! Tests for variable vector constructors + !------------------------------------------------------------------ + + do j = 1, 5 + a ((/ 1, (i + 3, i = 2, j) /)) = b (1:j) + call test ((/ 1, (i + 3, i = 2, j) /), id (1:j)) + + a (1:j) = b ((/ 1, (i + 3, i = 2, j) /)) + call test (id (1:j), (/ 1, (i + 3, i = 2, j) /)) + + a ((/ 1, (i + 3, i = 2, j) /)) = b ((/ 8, (i + 2, i = 2, j) /)) + call test ((/ 1, (i + 3, i = 2, j) /), (/ 8, (i + 2, i = 2, j) /)) + end do + + !------------------------------------------------------------------ + ! Tests in which the vector dimension is partnered by a temporary + !------------------------------------------------------------------ + + calls = 0 + a (idx (1:6)) = foo (6, calls) + if (calls .ne. 1) call abort + do i = 1, 6 + if (a (idx (i)) .ne. i + 3) call abort + end do + a = 0 + + calls = 0 + a (idx (1:6)) = foo (6, calls) * 100 + if (calls .ne. 1) call abort + do i = 1, 6 + if (a (idx (i)) .ne. (i + 3) * 100) call abort + end do + a = 0 + + a (idx) = id + 100 + do i = 1, n + if (a (idx (i)) .ne. i + 100) call abort + end do + a = 0 + + a (idx (1:10:3)) = (/ 20, 10, 9, 11 /) + if (a (idx (1)) .ne. 20) call abort + if (a (idx (4)) .ne. 10) call abort + if (a (idx (7)) .ne. 9) call abort + if (a (idx (10)) .ne. 11) call abort + a = 0 + +contains + subroutine test (lhs, rhs) + integer, dimension (:) :: lhs, rhs + integer :: i + + if (size (lhs, 1) .ne. size (rhs, 1)) call abort + do i = 1, size (lhs, 1) + if (a (lhs (i)) .ne. b (rhs (i))) call abort + end do + a = 0 + end subroutine test + + function foo (n, calls) + integer :: i, n, calls + integer, dimension (n) :: foo + + calls = calls + 1 + foo = (/ (i + 3, i = 1, n) /) + end function foo +end program main diff --git a/gcc/testsuite/gfortran.dg/vector_subscript_2.f90 b/gcc/testsuite/gfortran.dg/vector_subscript_2.f90 new file mode 100644 index 0000000..a5c024a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/vector_subscript_2.f90 @@ -0,0 +1,39 @@ +! Like vector_subscript_1.f90, but check subscripts in multi-dimensional +! arrays. +! { dg-do run } +program main + implicit none + integer, parameter :: n = 5 + integer :: i1, i2, i3 + integer, dimension (n, n, n) :: a, b + integer, dimension (n) :: idx, id + + idx = (/ 3, 1, 5, 2, 4 /) + id = (/ (i1, i1 = 1, n) /) + forall (i1 = 1:n, i2 = 1:n, i3 = 1:n) + b (i1, i2, i3) = i1 + i2 * 10 + i3 * 100 + end forall + + i1 = 5 + a (foo (i1), 1, :) = b (2, :, foo (i1)) + do i1 = 1, 5 + do i2 = 1, 5 + if (a (idx (i1), 1, i2) .ne. b (2, i1, idx (i2))) call abort + end do + end do + a = 0 + + a (1, idx (1:4), 2:4) = b (2:5, idx (3:5), 2) + do i1 = 1, 4 + do i2 = 1, 3 + if (a (1, idx (i1), 1 + i2) .ne. b (1 + i1, idx (i2 + 2), 2)) call abort + end do + end do + a = 0 +contains + function foo (n) + integer :: n + integer, dimension (n) :: foo + foo = idx (1:n) + end function foo +end program main |