diff options
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/ChangeLog | 29 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 138 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.c | 10 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.h | 7 | ||||
| -rw-r--r-- | gcc/fortran/trans-intrinsic.c | 2 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.c | 96 |
6 files changed, 256 insertions, 26 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 81790d8..ea08640 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,32 @@ +2006-01-07 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/22146 + * trans-array.c (gfc_reverse_ss): Remove static attribute. + (gfc_walk_elemental_function_args): Replace gfc_expr * argument for + the function call with the corresponding gfc_actual_arglist*. Change + code accordingly. + (gfc_walk_function_expr): Call to gfc_walk_elemental_function_args + now requires the actual argument list instead of the expression for + the function call. + * trans-array.h: Modify the prototype for gfc_walk_elemental_function_args + and provide a prototype for gfc_reverse_ss. + * trans-stmt.h (gfc_trans_call): Add the scalarization code for the case + where an elemental subroutine has array valued actual arguments. + + PR fortran/25029 + PR fortran/21256 + PR fortran/20868 + PR fortran/20870 + * resolve.c (check_assumed_size_reference): New function to check for upper + bound in assumed size array references. + (resolve_assumed_size_actual): New function to do a very restricted scan + of actual argument expressions of those procedures for which incomplete + assumed size array references are not allowed. + (resolve_function, resolve_call): Switch off assumed size checking of + actual arguments, except for elemental procedures and intrinsic + inquiry functions, in some circumstances. + (resolve_variable): Call check_assumed_size_reference. + 2006-01-05 Jerry DeLisle <jvdelisle@gcc.gnu.org> PR libgfortran/25598 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 2e870bb..5e64bf7 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -696,6 +696,69 @@ procedure_kind (gfc_symbol * sym) return PTYPE_UNKNOWN; } +/* Check references to assumed size arrays. The flag need_full_assumed_size + is non-zero when matching actual arguments. */ + +static int need_full_assumed_size = 0; + +static bool +check_assumed_size_reference (gfc_symbol * sym, gfc_expr * e) +{ + gfc_ref * ref; + int dim; + int last = 1; + + if (need_full_assumed_size + || !(sym->as && sym->as->type == AS_ASSUMED_SIZE)) + return false; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY) + for (dim = 0; dim < ref->u.ar.as->rank; dim++) + last = (ref->u.ar.end[dim] == NULL) && (ref->u.ar.type == DIMEN_ELEMENT); + + if (last) + { + gfc_error ("The upper bound in the last dimension must " + "appear in the reference to the assumed size " + "array '%s' at %L.", sym->name, &e->where); + return true; + } + return false; +} + + +/* Look for bad assumed size array references in argument expressions + of elemental and array valued intrinsic procedures. Since this is + called from procedure resolution functions, it only recurses at + operators. */ + +static bool +resolve_assumed_size_actual (gfc_expr *e) +{ + if (e == NULL) + return false; + + switch (e->expr_type) + { + case EXPR_VARIABLE: + if (e->symtree + && check_assumed_size_reference (e->symtree->n.sym, e)) + return true; + break; + + case EXPR_OP: + if (resolve_assumed_size_actual (e->value.op.op1) + || resolve_assumed_size_actual (e->value.op.op2)) + return true; + break; + + default: + break; + } + return false; +} + /* Resolve an actual argument list. Most of the time, this is just resolving the expressions in the list. @@ -1092,10 +1155,18 @@ resolve_function (gfc_expr * expr) gfc_actual_arglist *arg; const char *name; try t; + int temp; + + /* Switch off assumed size checking and do this again for certain kinds + of procedure, once the procedure itself is resolved. */ + need_full_assumed_size++; if (resolve_actual_arglist (expr->value.function.actual) == FAILURE) return FAILURE; + /* Resume assumed_size checking. */ + need_full_assumed_size--; + /* See if function is already resolved. */ if (expr->value.function.name != NULL) @@ -1133,6 +1204,9 @@ resolve_function (gfc_expr * expr) if (expr->expr_type != EXPR_FUNCTION) return t; + temp = need_full_assumed_size; + need_full_assumed_size = 0; + if (expr->value.function.actual != NULL && ((expr->value.function.esym != NULL && expr->value.function.esym->attr.elemental) @@ -1140,7 +1214,6 @@ resolve_function (gfc_expr * expr) && expr->value.function.isym->elemental))) { /* The rank of an elemental is the rank of its array argument(s). */ - for (arg = expr->value.function.actual; arg; arg = arg->next) { if (arg->expr != NULL && arg->expr->rank > 0) @@ -1149,8 +1222,45 @@ resolve_function (gfc_expr * expr) break; } } + + /* Being elemental, the last upper bound of an assumed size array + argument must be present. */ + for (arg = expr->value.function.actual; arg; arg = arg->next) + { + if (arg->expr != NULL + && arg->expr->rank > 0 + && resolve_assumed_size_actual (arg->expr)) + return FAILURE; + } } + else if (expr->value.function.actual != NULL + && expr->value.function.isym != NULL + && strcmp (expr->value.function.isym->name, "lbound")) + { + /* Array instrinsics must also have the last upper bound of an + asumed size array argument. UBOUND and SIZE have to be + excluded from the check if the second argument is anything + than a constant. */ + int inquiry; + inquiry = strcmp (expr->value.function.isym->name, "ubound") == 0 + || strcmp (expr->value.function.isym->name, "size") == 0; + + for (arg = expr->value.function.actual; arg; arg = arg->next) + { + if (inquiry && arg->next != NULL && arg->next->expr + && arg->next->expr->expr_type != EXPR_CONSTANT) + break; + + if (arg->expr != NULL + && arg->expr->rank > 0 + && resolve_assumed_size_actual (arg->expr)) + return FAILURE; + } + } + + need_full_assumed_size = temp; + if (!pure_function (expr, &name)) { if (forall_flag) @@ -1400,9 +1510,17 @@ resolve_call (gfc_code * c) { try t; + /* Switch off assumed size checking and do this again for certain kinds + of procedure, once the procedure itself is resolved. */ + need_full_assumed_size++; + if (resolve_actual_arglist (c->ext.actual) == FAILURE) return FAILURE; + /* Resume assumed_size checking. */ + need_full_assumed_size--; + + t = SUCCESS; if (c->resolved_sym == NULL) switch (procedure_kind (c->symtree->n.sym)) @@ -1423,6 +1541,21 @@ resolve_call (gfc_code * c) gfc_internal_error ("resolve_subroutine(): bad function type"); } + if (c->ext.actual != NULL + && c->symtree->n.sym->attr.elemental) + { + gfc_actual_arglist * a; + /* Being elemental, the last upper bound of an assumed size array + argument must be present. */ + for (a = c->ext.actual; a; a = a->next) + { + if (a->expr != NULL + && a->expr->rank > 0 + && resolve_assumed_size_actual (a->expr)) + return FAILURE; + } + } + if (t == SUCCESS) find_noncopying_intrinsics (c->resolved_sym, c->ext.actual); return t; @@ -2349,6 +2482,9 @@ resolve_variable (gfc_expr * e) e->ts = sym->ts; } + if (check_assumed_size_reference (sym, e)) + return FAILURE; + return SUCCESS; } diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index e943d8e..68bed0a 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -4529,7 +4529,7 @@ gfc_walk_op_expr (gfc_ss * ss, gfc_expr * expr) /* Reverse a SS chain. */ -static gfc_ss * +gfc_ss * gfc_reverse_ss (gfc_ss * ss) { gfc_ss *next; @@ -4555,10 +4555,9 @@ gfc_reverse_ss (gfc_ss * ss) /* Walk the arguments of an elemental function. */ gfc_ss * -gfc_walk_elemental_function_args (gfc_ss * ss, gfc_expr * expr, +gfc_walk_elemental_function_args (gfc_ss * ss, gfc_actual_arglist *arg, gfc_ss_type type) { - gfc_actual_arglist *arg; int scalar; gfc_ss *head; gfc_ss *tail; @@ -4567,7 +4566,7 @@ gfc_walk_elemental_function_args (gfc_ss * ss, gfc_expr * expr, head = gfc_ss_terminator; tail = NULL; scalar = 1; - for (arg = expr->value.function.actual; arg; arg = arg->next) + for (; arg; arg = arg->next) { if (!arg->expr) continue; @@ -4644,7 +4643,8 @@ gfc_walk_function_expr (gfc_ss * ss, gfc_expr * expr) /* Walk the parameters of an elemental function. For now we always pass by reference. */ if (sym->attr.elemental) - return gfc_walk_elemental_function_args (ss, expr, GFC_SS_REFERENCE); + return gfc_walk_elemental_function_args (ss, expr->value.function.actual, + GFC_SS_REFERENCE); /* Scalar functions are OK as these are evaluated outside the scalarization loop. Pass back and let the caller deal with it. */ diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 8ceced9..564e649 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -48,11 +48,14 @@ void gfc_trans_static_array_pointer (gfc_symbol *); /* Generate scalarization information for an expression. */ gfc_ss *gfc_walk_expr (gfc_expr *); -/* Walk the arguments of an intrinsic function. */ -gfc_ss *gfc_walk_elemental_function_args (gfc_ss *, gfc_expr *, gfc_ss_type); +/* Walk the arguments of an elemental function. */ +gfc_ss *gfc_walk_elemental_function_args (gfc_ss *, gfc_actual_arglist *, + gfc_ss_type); /* Walk an intrinsic function. */ gfc_ss *gfc_walk_intrinsic_function (gfc_ss *, gfc_expr *, gfc_intrinsic_sym *); +/* Reverse the order of an SS chain. */ +gfc_ss *gfc_reverse_ss (gfc_ss *); /* Free the SS associated with a loop. */ void gfc_cleanup_loop (gfc_loopinfo *); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index e3f4bdf..699a294 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -3380,7 +3380,7 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr, gcc_assert (isym); if (isym->elemental) - return gfc_walk_elemental_function_args (ss, expr, GFC_SS_SCALAR); + return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR); if (expr->rank == 0) return ss; diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 1b56cf4..cf88918 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -209,6 +209,7 @@ tree gfc_trans_call (gfc_code * code) { gfc_se se; + gfc_ss * ss; int has_alternate_specifier; /* A CALL starts a new block because the actual arguments may have to @@ -218,28 +219,81 @@ gfc_trans_call (gfc_code * code) gcc_assert (code->resolved_sym); - /* Translate the call. */ - has_alternate_specifier - = gfc_conv_function_call (&se, code->resolved_sym, code->ext.actual); + ss = gfc_ss_terminator; + if (code->resolved_sym->attr.elemental) + ss = gfc_walk_elemental_function_args (ss, code->ext.actual, GFC_SS_REFERENCE); - /* A subroutine without side-effect, by definition, does nothing! */ - TREE_SIDE_EFFECTS (se.expr) = 1; - - /* Chain the pieces together and return the block. */ - if (has_alternate_specifier) + /* Is not an elemental subroutine call with array valued arguments. */ + if (ss == gfc_ss_terminator) { - gfc_code *select_code; - gfc_symbol *sym; - select_code = code->next; - gcc_assert(select_code->op == EXEC_SELECT); - sym = select_code->expr->symtree->n.sym; - se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr); - gfc_add_modify_expr (&se.pre, sym->backend_decl, se.expr); + + /* Translate the call. */ + has_alternate_specifier + = gfc_conv_function_call (&se, code->resolved_sym, code->ext.actual); + + /* A subroutine without side-effect, by definition, does nothing! */ + TREE_SIDE_EFFECTS (se.expr) = 1; + + /* Chain the pieces together and return the block. */ + if (has_alternate_specifier) + { + gfc_code *select_code; + gfc_symbol *sym; + select_code = code->next; + gcc_assert(select_code->op == EXEC_SELECT); + sym = select_code->expr->symtree->n.sym; + se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr); + gfc_add_modify_expr (&se.pre, sym->backend_decl, se.expr); + } + else + gfc_add_expr_to_block (&se.pre, se.expr); + + gfc_add_block_to_block (&se.pre, &se.post); } + else - gfc_add_expr_to_block (&se.pre, se.expr); + { + /* An elemental subroutine call with array valued arguments has + to be scalarized. */ + gfc_loopinfo loop; + stmtblock_t body; + stmtblock_t block; + gfc_se loopse; + + /* gfc_walk_elemental_function_args renders the ss chain in the + reverse order to the actual argument order. */ + ss = gfc_reverse_ss (ss); + + /* Initialize the loop. */ + gfc_init_se (&loopse, NULL); + gfc_init_loopinfo (&loop); + gfc_add_ss_to_loop (&loop, ss); + + gfc_conv_ss_startstride (&loop); + gfc_conv_loop_setup (&loop); + gfc_mark_ss_chain_used (ss, 1); + + /* Generate the loop body. */ + gfc_start_scalarized_body (&loop, &body); + gfc_init_block (&block); + gfc_copy_loopinfo_to_se (&loopse, &loop); + loopse.ss = ss; + + /* Add the subroutine call to the block. */ + gfc_conv_function_call (&loopse, code->resolved_sym, code->ext.actual); + gfc_add_expr_to_block (&loopse.pre, loopse.expr); + + gfc_add_block_to_block (&block, &loopse.pre); + gfc_add_block_to_block (&block, &loopse.post); + + /* Finish up the loop block and the loop. */ + gfc_add_expr_to_block (&body, gfc_finish_block (&block)); + gfc_trans_scalarizing_loops (&loop, &body); + gfc_add_block_to_block (&se.pre, &loop.pre); + gfc_add_block_to_block (&se.pre, &loop.post); + gfc_cleanup_loop (&loop); + } - gfc_add_block_to_block (&se.pre, &se.post); return gfc_finish_block (&se.pre); } @@ -2501,6 +2555,14 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) gfc_add_expr_to_block (&block, tmp); break; + /* Explicit subroutine calls are prevented by the frontend but interface + assignments can legitimately produce them. */ + case EXEC_CALL: + assign = gfc_trans_call (c); + tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1); + gfc_add_expr_to_block (&block, tmp); + break; + default: gcc_unreachable (); } |