diff options
| author | Paul Thomas <pault@gcc.gnu.org> | 2019-09-01 12:53:02 +0000 |
|---|---|---|
| committer | Paul Thomas <pault@gcc.gnu.org> | 2019-09-01 12:53:02 +0000 |
| commit | 70570ec1927450952efc5baa4de3254507352f09 (patch) | |
| tree | d0baf00593ad714a097942a7238267ec362f1411 /gcc/fortran/resolve.c | |
| parent | 3e7254c5e4a0545059ca61b34134f7ef5c3d3a86 (diff) | |
| download | gcc-70570ec1927450952efc5baa4de3254507352f09.zip gcc-70570ec1927450952efc5baa4de3254507352f09.tar.gz gcc-70570ec1927450952efc5baa4de3254507352f09.tar.bz2 | |
array.c (spec_dimen_size): Check for the presence of expressions for the bounds.
2019-09-01 Paul Thomas <pault@gcc.gnu.org>
* array.c (spec_dimen_size): Check for the presence of
expressions for the bounds.
* decl.c (gfc_match_end): Add case COMP_SELECT_RANK.
* dump-parse-tree.c(show_symbol): Show the arrayspec of class
entities.
(show_code_node): Show the code for SELECT_RANK.
* expr.c (gfc_check_vardef_context): Omit the context of
variable definition for select rank associate names since the
ASSUMED RANK throws.
* gfortran.h : Add ST_SELECT_RANK and ST_RANK to enum
gfc_statement. Add select_rank_temporary to symbol attribute
structure. Add EXEC_SELECT_RANK to enum gfc_exec_op.
* match.c (match_exit_cycle): Add COMP_SELECT_RANK.
(copy_ts_from_selector_to_associate): Add as special case for
assumed rank class variables.
(select_intrinsic_set_tmp): Clean up the code by using symbols
for references to the temporary and the selector.
(select_type_set_tmp): Ditto.
(select_rank_set_tmp): New function.
(gfc_match_select_rank): New function.
(gfc_match_rank_is): New function.
* match.h : Add prototypes for gfc_match_select_rank and
gfc_match_rank_is.
* parse.c (decode_statement): Attempt to match select_rank and
rank statements.
(next_statement, gfc_ascii_statement): Add ST_SELECT_RANK.
(parse_select_rank_block): New function.
(parse_executable): Parse select rank block for ST_SELECT_RANK.
* parse.h : Add COMP_SELECT_RANK to enum gfc_compile_state.
* resolve.c (resolve_variable): Exclude select_rank_temporaries
from the check on use of ASSUMED RANK.
(gfc_resolve_expr): Make sure that unlimited polymorphic select
rank temporaries expressions are not resolved again after being
successfully resolved.
(resolve_assoc_var): Do not do the rank check for select rank
temporaries.
(resolve_select_rank): New function.
(gfc_resolve_blocks): Deal with case EXEC_SELECT_RANK.
(resolve_symbol): Exclude select rank temporaries for check on
use of ASSUMED RANK.
* st.c (gfc_free_statement): Include EXEC_SELECT_RANK.
* trans-array.c (gfc_conv_array_ref): Select rank temporaries
may have dimen == 0.
(gfc_conv_expr_descriptor): Zero the offset of select rank
temporaries.
* trans-stmt.c (copy_descriptor): New function.
(trans_associate_var): Add code to associate select rank temps.
(gfc_trans_select_rank_cases): New function.
(gfc_trans_select_rank): New function.
* trans-stmt.h : Add prototype for gfc_trans_select_rank.
trans.c (trans_code): Add select rank case.
2019-09-01 Paul Thomas <pault@gcc.gnu.org>
* gfortran.dg/select_rank_1.f90 : New test.
* gfortran.dg/select_rank_2.f90 : New test.
From-SVN: r275269
Diffstat (limited to 'gcc/fortran/resolve.c')
| -rw-r--r-- | gcc/fortran/resolve.c | 210 |
1 files changed, 198 insertions, 12 deletions
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 1f48045..383ba44 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1866,7 +1866,7 @@ resolve_procedure_expression (gfc_expr* expr) /* Check that name is not a derived type. */ - + static bool is_dt_name (const char *name) { @@ -5455,13 +5455,16 @@ resolve_variable (gfc_expr *e) } } /* TS 29113, C535b. */ - else if ((sym->ts.type == BT_CLASS && sym->attr.class_ok - && CLASS_DATA (sym)->as - && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) - || (sym->ts.type != BT_CLASS && sym->as - && sym->as->type == AS_ASSUMED_RANK)) + else if (((sym->ts.type == BT_CLASS && sym->attr.class_ok + && CLASS_DATA (sym)->as + && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) + || (sym->ts.type != BT_CLASS && sym->as + && sym->as->type == AS_ASSUMED_RANK)) + && !sym->attr.select_rank_temporary) { - if (!actual_arg) + if (!actual_arg + && !(cs_base && cs_base->current + && cs_base->current->op == EXEC_SELECT_RANK)) { gfc_error ("Assumed-rank variable %s at %L may only be used as " "actual argument", sym->name, &e->where); @@ -6915,7 +6918,7 @@ gfc_resolve_expr (gfc_expr *e) bool t; bool inquiry_save, actual_arg_save, first_actual_arg_save; - if (e == NULL) + if (e == NULL || e->do_not_resolve_again) return true; /* inquiry_argument only applies to variables. */ @@ -7025,6 +7028,13 @@ gfc_resolve_expr (gfc_expr *e) actual_arg = actual_arg_save; first_actual_arg = first_actual_arg_save; + /* For some reason, resolving these expressions a second time mangles + the typespec of the expression itself. */ + if (t && e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.select_rank_temporary + && UNLIMITED_POLY (e->symtree->n.sym)) + e->do_not_resolve_again = 1; + return t; } @@ -8841,7 +8851,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) if (target->ts.type == BT_CLASS) gfc_fix_class_refs (target); - if (target->rank != 0) + if (target->rank != 0 && !sym->attr.select_rank_temporary) { gfc_array_spec *as; /* The rank may be incorrectly guessed at parsing, therefore make sure @@ -8871,7 +8881,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) CLASS_DATA (sym)->attr.codimension = 1; } } - else + else if (!sym->attr.select_rank_temporary) { /* target's rank is 0, but the type of the sym is still array valued, which has to be corrected. */ @@ -9490,6 +9500,175 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) } +/* Resolve a SELECT RANK statement. */ + +static void +resolve_select_rank (gfc_code *code, gfc_namespace *old_ns) +{ + gfc_namespace *ns; + gfc_code *body, *new_st, *tail; + gfc_case *c; + char tname[GFC_MAX_SYMBOL_LEN]; + char name[2 * GFC_MAX_SYMBOL_LEN]; + gfc_symtree *st; + gfc_expr *selector_expr = NULL; + int case_value; + HOST_WIDE_INT charlen = 0; + + ns = code->ext.block.ns; + gfc_resolve (ns); + + code->op = EXEC_BLOCK; + if (code->expr2) + { + gfc_association_list* assoc; + + assoc = gfc_get_association_list (); + assoc->st = code->expr1->symtree; + assoc->target = gfc_copy_expr (code->expr2); + assoc->target->where = code->expr2->where; + /* assoc->variable will be set by resolve_assoc_var. */ + + code->ext.block.assoc = assoc; + code->expr1->symtree->n.sym->assoc = assoc; + + resolve_assoc_var (code->expr1->symtree->n.sym, false); + } + else + code->ext.block.assoc = NULL; + + /* Loop over RANK cases. Note that returning on the errors causes a + cascade of further errors because the case blocks do not compile + correctly. */ + for (body = code->block; body; body = body->block) + { + c = body->ext.block.case_list; + if (c->low) + case_value = (int) mpz_get_si (c->low->value.integer); + else + case_value = -2; + + /* Check for repeated cases. */ + for (tail = code->block; tail; tail = tail->block) + { + gfc_case *d = tail->ext.block.case_list; + int case_value2; + + if (tail == body) + break; + + /* Check F2018: C1153. */ + if (!c->low && !d->low) + gfc_error ("RANK DEFAULT at %L is repeated at %L", + &c->where, &d->where); + + if (!c->low || !d->low) + continue; + + /* Check F2018: C1153. */ + case_value2 = (int) mpz_get_si (d->low->value.integer); + if ((case_value == case_value2) && case_value == -1) + gfc_error ("RANK (*) at %L is repeated at %L", + &c->where, &d->where); + else if (case_value == case_value2) + gfc_error ("RANK (%i) at %L is repeated at %L", + case_value, &c->where, &d->where); + } + + if (!c->low) + continue; + + /* Check F2018: C1155. */ + if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable + || gfc_expr_attr (code->expr1).pointer)) + gfc_error ("RANK (*) at %L cannot be used with the pointer or " + "allocatable selector at %L", &c->where, &code->expr1->where); + + if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable + || gfc_expr_attr (code->expr1).pointer)) + gfc_error ("RANK (*) at %L cannot be used with the pointer or " + "allocatable selector at %L", &c->where, &code->expr1->where); + } + + /* Add EXEC_SELECT to switch on rank. */ + new_st = gfc_get_code (code->op); + new_st->expr1 = code->expr1; + new_st->expr2 = code->expr2; + new_st->block = code->block; + code->expr1 = code->expr2 = NULL; + code->block = NULL; + if (!ns->code) + ns->code = new_st; + else + ns->code->next = new_st; + code = new_st; + code->op = EXEC_SELECT_RANK; + + selector_expr = code->expr1; + + /* Loop over SELECT RANK cases. */ + for (body = code->block; body; body = body->block) + { + c = body->ext.block.case_list; + int case_value; + + /* Pass on the default case. */ + if (c->low == NULL) + continue; + + /* Associate temporary to selector. This should only be done + when this case is actually true, so build a new ASSOCIATE + that does precisely this here (instead of using the + 'global' one). */ + if (c->ts.type == BT_CHARACTER && c->ts.u.cl && c->ts.u.cl->length + && c->ts.u.cl->length->expr_type == EXPR_CONSTANT) + charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer); + + if (c->ts.type == BT_CLASS) + sprintf (tname, "class_%s", c->ts.u.derived->name); + else if (c->ts.type == BT_DERIVED) + sprintf (tname, "type_%s", c->ts.u.derived->name); + else if (c->ts.type != BT_CHARACTER) + sprintf (tname, "%s_%d", gfc_basic_typename (c->ts.type), c->ts.kind); + else + sprintf (tname, "%s_" HOST_WIDE_INT_PRINT_DEC "_%d", + gfc_basic_typename (c->ts.type), charlen, c->ts.kind); + + case_value = (int) mpz_get_si (c->low->value.integer); + if (case_value >= 0) + sprintf (name, "__tmp_%s_rank_%d", tname, case_value); + else + sprintf (name, "__tmp_%s_rank_m%d", tname, -case_value); + + st = gfc_find_symtree (ns->sym_root, name); + gcc_assert (st->n.sym->assoc); + + st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree); + st->n.sym->assoc->target->where = selector_expr->where; + + new_st = gfc_get_code (EXEC_BLOCK); + new_st->ext.block.ns = gfc_build_block_ns (ns); + new_st->ext.block.ns->code = body->next; + body->next = new_st; + + /* Chain in the new list only if it is marked as dangling. Otherwise + there is a CASE label overlap and this is already used. Just ignore, + the error is diagnosed elsewhere. */ + if (st->n.sym->assoc->dangling) + { + new_st->ext.block.assoc = st->n.sym->assoc; + st->n.sym->assoc->dangling = 0; + } + + resolve_assoc_var (st->n.sym, false); + } + + gfc_current_ns = ns; + gfc_resolve_blocks (code->block, gfc_current_ns); + gfc_current_ns = old_ns; +} + + /* Resolve a transfer statement. This is making sure that: -- a derived type being transferred has only non-pointer components -- a derived type being transferred doesn't have private components, unless @@ -10366,6 +10545,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) case EXEC_SELECT: case EXEC_SELECT_TYPE: + case EXEC_SELECT_RANK: case EXEC_FORALL: case EXEC_DO: case EXEC_DO_WHILE: @@ -11643,6 +11823,10 @@ start: resolve_select_type (code, ns); break; + case EXEC_SELECT_RANK: + resolve_select_rank (code, ns); + break; + case EXEC_BLOCK: resolve_block_construct (code); break; @@ -13573,7 +13757,7 @@ resolve_typebound_procedure (gfc_symtree* stree) } else { - /* If proc has not been resolved at this point, proc->name may + /* If proc has not been resolved at this point, proc->name may actually be a USE associated entity. See PR fortran/89647. */ if (!proc->resolved && proc->attr.function == 0 && proc->attr.subroutine == 0) @@ -15048,7 +15232,9 @@ resolve_symbol (gfc_symbol *sym) } /* TS 29113, C535a. */ if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy - && !sym->attr.select_type_temporary) + && !sym->attr.select_type_temporary + && !(cs_base && cs_base->current + && cs_base->current->op == EXEC_SELECT_RANK)) { gfc_error ("Assumed-rank array at %L must be a dummy argument", &sym->declared_at); |