From 70570ec1927450952efc5baa4de3254507352f09 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sun, 1 Sep 2019 12:53:02 +0000 Subject: [PATCH] array.c (spec_dimen_size): Check for the presence of expressions for the bounds. 2019-09-01 Paul Thomas * 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 * gfortran.dg/select_rank_1.f90 : New test. * gfortran.dg/select_rank_2.f90 : New test. From-SVN: r275269 --- gcc/fortran/ChangeLog | 56 ++- gcc/fortran/array.c | 6 +- gcc/fortran/decl.c | 1 + gcc/fortran/dump-parse-tree.c | 20 +- gcc/fortran/expr.c | 2 +- gcc/fortran/gfortran.h | 12 +- gcc/fortran/match.c | 427 ++++++++++++++++++-- gcc/fortran/match.h | 2 + gcc/fortran/parse.c | 95 ++++- gcc/fortran/parse.h | 3 +- gcc/fortran/resolve.c | 210 +++++++++- gcc/fortran/st.c | 1 + gcc/fortran/trans-array.c | 8 +- gcc/fortran/trans-stmt.c | 315 ++++++++++++++- gcc/fortran/trans-stmt.h | 1 + gcc/fortran/trans.c | 4 + gcc/testsuite/ChangeLog | 5 + gcc/testsuite/gfortran.dg/select_rank_1.f90 | 179 ++++++++ gcc/testsuite/gfortran.dg/select_rank_2.f90 | 85 ++++ 19 files changed, 1355 insertions(+), 77 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/select_rank_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/select_rank_2.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index a34b871c4c4..0ed86cee170 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,57 @@ +2019-09-01 Paul Thomas + + * 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-08-30 Steven G. Kargl PR fortran/91587 @@ -49,7 +103,7 @@ 2019-08-27 Mark Eggleston * invoke.texi: Ensure that the option lists fit within the - margins of a PDF page. Re-worded description of + margins of a PDF page. Re-worded description of '-ffrontend-loop-interchange' so that it fits with the margins of a PDF page. Add '-fdec-include', '-fdec-blank-format-item' and '-fdec-format-defaults' to list of options that are enabled diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index b958e894d59..b972abe8a38 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -2213,7 +2213,11 @@ spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result) gfc_internal_error ("spec_dimen_size(): Bad dimension"); if (as->type != AS_EXPLICIT - || as->lower[dimen]->expr_type != EXPR_CONSTANT + || !as->lower[dimen] + || !as->upper[dimen]) + return false; + + if (as->lower[dimen]->expr_type != EXPR_CONSTANT || as->upper[dimen]->expr_type != EXPR_CONSTANT || as->lower[dimen]->ts.type != BT_INTEGER || as->upper[dimen]->ts.type != BT_INTEGER) diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index d5c8c339e70..071119157d6 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -8164,6 +8164,7 @@ gfc_match_end (gfc_statement *st) case COMP_SELECT: case COMP_SELECT_TYPE: + case COMP_SELECT_RANK: *st = ST_END_SELECT; target = " select"; eos_ok = 0; diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index 798519fa6af..513f211b68b 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -1000,12 +1000,18 @@ show_symbol (gfc_symbol *sym) show_expr (sym->value); } - if (sym->as) + if (sym->ts.type != BT_CLASS && sym->as) { show_indent (); fputs ("Array spec:", dumpfile); show_array_spec (sym->as); } + else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as) + { + show_indent (); + fputs ("Array spec:", dumpfile); + show_array_spec (CLASS_DATA (sym)->as); + } if (sym->generic) { @@ -2168,18 +2174,22 @@ show_code_node (int level, gfc_code *c) case EXEC_SELECT: case EXEC_SELECT_TYPE: + case EXEC_SELECT_RANK: d = c->block; - if (c->op == EXEC_SELECT_TYPE) + fputc ('\n', dumpfile); + code_indent (level, 0); + if (c->op == EXEC_SELECT_RANK) + fputs ("SELECT RANK ", dumpfile); + else if (c->op == EXEC_SELECT_TYPE) fputs ("SELECT TYPE ", dumpfile); else fputs ("SELECT CASE ", dumpfile); show_expr (c->expr1); - fputc ('\n', dumpfile); for (; d; d = d->block) { + fputc ('\n', dumpfile); code_indent (level, 0); - fputs ("CASE ", dumpfile); for (cp = d->ext.block.case_list; cp; cp = cp->next) { @@ -2190,9 +2200,9 @@ show_code_node (int level, gfc_code *c) fputc (')', dumpfile); fputc (' ', dumpfile); } - fputc ('\n', dumpfile); show_code (level + 1, d->next); + fputc ('\n', dumpfile); } code_indent (level, c->label1); diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 451609442bc..c6d17d6f27f 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -6181,7 +6181,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj, } } /* Check variable definition context for associate-names. */ - if (!pointer && sym->assoc) + if (!pointer && sym->assoc && !sym->attr.select_rank_temporary) { const char* name; gfc_association_list* assoc; diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index d2f40dfdb91..80e31ee1a87 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -216,7 +216,7 @@ enum gfc_statement ST_POINTER_ASSIGNMENT, ST_SELECT_CASE, ST_SEQUENCE, ST_SIMPLE_IF, ST_STATEMENT_FUNCTION, ST_DERIVED_DECL, ST_LABEL_ASSIGNMENT, ST_ENUM, ST_ENUMERATOR, ST_END_ENUM, ST_SELECT_TYPE, ST_TYPE_IS, ST_CLASS_IS, - ST_STRUCTURE_DECL, ST_END_STRUCTURE, + ST_SELECT_RANK, ST_RANK, ST_STRUCTURE_DECL, ST_END_STRUCTURE, ST_UNION, ST_END_UNION, ST_MAP, ST_END_MAP, ST_OACC_PARALLEL_LOOP, ST_OACC_END_PARALLEL_LOOP, ST_OACC_PARALLEL, ST_OACC_END_PARALLEL, ST_OACC_KERNELS, ST_OACC_END_KERNELS, ST_OACC_DATA, @@ -894,9 +894,9 @@ typedef struct event_comp:1, defined_assign_comp:1, unlimited_polymorphic:1, has_dtio_procs:1, caf_token:1; - /* This is a temporary selector for SELECT TYPE or an associate - variable for SELECT_TYPE or ASSOCIATE. */ - unsigned select_type_temporary:1, associate_var:1; + /* This is a temporary selector for SELECT TYPE/RANK or an associate + variable for SELECT TYPE/RANK or ASSOCIATE. */ + unsigned select_type_temporary:1, select_rank_temporary:1, associate_var:1; /* These are the attributes required for parameterized derived types. */ @@ -2555,8 +2555,8 @@ enum gfc_exec_op EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_CONCURRENT, EXEC_DO_WHILE, EXEC_SELECT, EXEC_BLOCK, EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT, EXEC_CALL_PPC, EXEC_ALLOCATE, EXEC_DEALLOCATE, EXEC_END_PROCEDURE, - EXEC_SELECT_TYPE, EXEC_SYNC_ALL, EXEC_SYNC_MEMORY, EXEC_SYNC_IMAGES, - EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT, + EXEC_SELECT_TYPE, EXEC_SELECT_RANK, EXEC_SYNC_ALL, EXEC_SYNC_MEMORY, + EXEC_SYNC_IMAGES, EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT, EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END, EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH, EXEC_FORM_TEAM, EXEC_CHANGE_TEAM, EXEC_END_TEAM, EXEC_SYNC_TEAM, diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index f148a02eb50..56d9af04777 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -2825,6 +2825,7 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op) case COMP_IF: case COMP_SELECT: case COMP_SELECT_TYPE: + case COMP_SELECT_RANK: gcc_assert (sym); if (op == EXEC_CYCLE) { @@ -6065,7 +6066,14 @@ copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector) ref = ref->next; if (selector->ts.type == BT_CLASS && CLASS_DATA (selector)->as - && ref && ref->type == REF_ARRAY) + && CLASS_DATA (selector)->as->type == AS_ASSUMED_RANK) + { + assoc_sym->attr.dimension = 1; + assoc_sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as); + goto build_class_sym; + } + else if (selector->ts.type == BT_CLASS && CLASS_DATA (selector)->as + && ref && ref->type == REF_ARRAY) { /* Ensure that the array reference type is set. We cannot use gfc_resolve_expr at this point, so the usable parts of @@ -6116,6 +6124,7 @@ copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector) else assoc_sym->as = NULL; +build_class_sym: if (selector->ts.type == BT_CLASS) { /* The correct class container has to be available. */ @@ -6149,14 +6158,17 @@ select_intrinsic_set_tmp (gfc_typespec *ts) char name[GFC_MAX_SYMBOL_LEN]; gfc_symtree *tmp; HOST_WIDE_INT charlen = 0; + gfc_symbol *selector = select_type_stack->selector; + gfc_symbol *sym; if (ts->type == BT_CLASS || ts->type == BT_DERIVED) return NULL; - if (select_type_stack->selector->ts.type == BT_CLASS - && !select_type_stack->selector->attr.class_ok) + if (selector->ts.type == BT_CLASS && !selector->attr.class_ok) return NULL; + /* Case value == NULL corresponds to SELECT TYPE cases otherwise + the values correspond to SELECT rank cases. */ if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length && ts->u.cl->length->expr_type == EXPR_CONSTANT) charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); @@ -6165,29 +6177,28 @@ select_intrinsic_set_tmp (gfc_typespec *ts) sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type), ts->kind); else - snprintf (name, sizeof (name), "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d", + snprintf (name, sizeof (name), + "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d", gfc_basic_typename (ts->type), charlen, ts->kind); gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); - gfc_add_type (tmp->n.sym, ts, NULL); + sym = tmp->n.sym; + gfc_add_type (sym, ts, NULL); /* Copy across the array spec to the selector. */ - if (select_type_stack->selector->ts.type == BT_CLASS - && (CLASS_DATA (select_type_stack->selector)->attr.dimension - || CLASS_DATA (select_type_stack->selector)->attr.codimension)) + if (selector->ts.type == BT_CLASS + && (CLASS_DATA (selector)->attr.dimension + || CLASS_DATA (selector)->attr.codimension)) { - tmp->n.sym->attr.pointer = 1; - tmp->n.sym->attr.dimension - = CLASS_DATA (select_type_stack->selector)->attr.dimension; - tmp->n.sym->attr.codimension - = CLASS_DATA (select_type_stack->selector)->attr.codimension; - tmp->n.sym->as - = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as); + sym->attr.pointer = 1; + sym->attr.dimension = CLASS_DATA (selector)->attr.dimension; + sym->attr.codimension = CLASS_DATA (selector)->attr.codimension; + sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as); } - gfc_set_sym_referenced (tmp->n.sym); - gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL); - tmp->n.sym->attr.select_type_temporary = 1; + gfc_set_sym_referenced (sym); + gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL); + sym->attr.select_type_temporary = 1; return tmp; } @@ -6200,6 +6211,8 @@ select_type_set_tmp (gfc_typespec *ts) { char name[GFC_MAX_SYMBOL_LEN]; gfc_symtree *tmp = NULL; + gfc_symbol *selector = select_type_stack->selector; + gfc_symbol *sym; if (!ts) { @@ -6218,42 +6231,45 @@ select_type_set_tmp (gfc_typespec *ts) sprintf (name, "__tmp_class_%s", ts->u.derived->name); else sprintf (name, "__tmp_type_%s", ts->u.derived->name); + gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); - gfc_add_type (tmp->n.sym, ts, NULL); + sym = tmp->n.sym; + gfc_add_type (sym, ts, NULL); - if (select_type_stack->selector->ts.type == BT_CLASS - && select_type_stack->selector->attr.class_ok) + if (selector->ts.type == BT_CLASS && selector->attr.class_ok) { - tmp->n.sym->attr.pointer - = CLASS_DATA (select_type_stack->selector)->attr.class_pointer; + sym->attr.pointer + = CLASS_DATA (selector)->attr.class_pointer; /* Copy across the array spec to the selector. */ - if (CLASS_DATA (select_type_stack->selector)->attr.dimension - || CLASS_DATA (select_type_stack->selector)->attr.codimension) + if (CLASS_DATA (selector)->attr.dimension + || CLASS_DATA (selector)->attr.codimension) { - tmp->n.sym->attr.dimension - = CLASS_DATA (select_type_stack->selector)->attr.dimension; - tmp->n.sym->attr.codimension - = CLASS_DATA (select_type_stack->selector)->attr.codimension; - tmp->n.sym->as - = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as); + sym->attr.dimension + = CLASS_DATA (selector)->attr.dimension; + sym->attr.codimension + = CLASS_DATA (selector)->attr.codimension; + sym->as + = gfc_copy_array_spec (CLASS_DATA (selector)->as); } - } + } - gfc_set_sym_referenced (tmp->n.sym); - gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL); - tmp->n.sym->attr.select_type_temporary = 1; + gfc_set_sym_referenced (sym); + gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL); + sym->attr.select_type_temporary = 1; - if (ts->type == BT_CLASS) - gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr, - &tmp->n.sym->as); + if (ts->type == BT_CLASS) + gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as); } + else + sym = tmp->n.sym; + /* Add an association for it, so the rest of the parser knows it is an associate-name. The target will be set during resolution. */ - tmp->n.sym->assoc = gfc_get_association_list (); - tmp->n.sym->assoc->dangling = 1; - tmp->n.sym->assoc->st = tmp; + sym->assoc = gfc_get_association_list (); + sym->assoc->dangling = 1; + sym->assoc->st = tmp; select_type_stack->tmp = tmp; } @@ -6374,6 +6390,234 @@ cleanup: } +/* Set the temporary for the current intrinsic SELECT RANK selector. */ + +static void +select_rank_set_tmp (gfc_typespec *ts, int *case_value) +{ + char name[2 * GFC_MAX_SYMBOL_LEN]; + char tname[GFC_MAX_SYMBOL_LEN]; + gfc_symtree *tmp; + gfc_symbol *selector = select_type_stack->selector; + gfc_symbol *sym; + gfc_symtree *st; + HOST_WIDE_INT charlen = 0; + + if (case_value == NULL) + return; + + if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length + && ts->u.cl->length->expr_type == EXPR_CONSTANT) + charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer); + + if (ts->type == BT_CLASS) + sprintf (tname, "class_%s", ts->u.derived->name); + else if (ts->type == BT_DERIVED) + sprintf (tname, "type_%s", ts->u.derived->name); + else if (ts->type != BT_CHARACTER) + sprintf (tname, "%s_%d", gfc_basic_typename (ts->type), ts->kind); + else + sprintf (tname, "%s_" HOST_WIDE_INT_PRINT_DEC "_%d", + gfc_basic_typename (ts->type), charlen, ts->kind); + + /* Case value == NULL corresponds to SELECT TYPE cases otherwise + the values correspond to SELECT rank cases. */ + if (*case_value >=0) + sprintf (name, "__tmp_%s_rank_%d", tname, *case_value); + else + sprintf (name, "__tmp_%s_rank_m%d", tname, -*case_value); + + gfc_find_sym_tree (name, gfc_current_ns, 0, &st); + if (st) + return; + + gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); + sym = tmp->n.sym; + gfc_add_type (sym, ts, NULL); + + /* Copy across the array spec to the selector. */ + if (selector->ts.type == BT_CLASS) + { + sym->ts.u.derived = CLASS_DATA (selector)->ts.u.derived; + sym->attr.pointer = CLASS_DATA (selector)->attr.pointer; + sym->attr.allocatable = CLASS_DATA (selector)->attr.allocatable; + sym->attr.target = CLASS_DATA (selector)->attr.target; + sym->attr.class_ok = 0; + if (case_value && *case_value != 0) + { + sym->attr.dimension = 1; + sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as); + if (*case_value > 0) + { + sym->as->type = AS_DEFERRED; + sym->as->rank = *case_value; + } + else if (*case_value == -1) + { + sym->as->type = AS_ASSUMED_SIZE; + sym->as->rank = 1; + } + } + } + else + { + sym->attr.pointer = selector->attr.pointer; + sym->attr.allocatable = selector->attr.allocatable; + sym->attr.target = selector->attr.target; + if (case_value && *case_value != 0) + { + sym->attr.dimension = 1; + sym->as = gfc_copy_array_spec (selector->as); + if (*case_value > 0) + { + sym->as->type = AS_DEFERRED; + sym->as->rank = *case_value; + } + else if (*case_value == -1) + { + sym->as->type = AS_ASSUMED_SIZE; + sym->as->rank = 1; + } + } + } + + gfc_set_sym_referenced (sym); + gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL); + sym->attr.select_type_temporary = 1; + if (case_value) + sym->attr.select_rank_temporary = 1; + + if (ts->type == BT_CLASS) + gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as); + + /* Add an association for it, so the rest of the parser knows it is + an associate-name. The target will be set during resolution. */ + sym->assoc = gfc_get_association_list (); + sym->assoc->dangling = 1; + sym->assoc->st = tmp; + + select_type_stack->tmp = tmp; +} + + +/* Match a SELECT RANK statement. */ + +match +gfc_match_select_rank (void) +{ + gfc_expr *expr1, *expr2 = NULL; + match m; + char name[GFC_MAX_SYMBOL_LEN]; + gfc_symbol *sym, *sym2; + gfc_namespace *ns = gfc_current_ns; + gfc_array_spec *as; + + m = gfc_match_label (); + if (m == MATCH_ERROR) + return m; + + m = gfc_match (" select rank ( "); + if (m != MATCH_YES) + return m; + + if (!gfc_notify_std (GFC_STD_F2018, "SELECT RANK statement at %C")) + return MATCH_NO; + + gfc_current_ns = gfc_build_block_ns (ns); + m = gfc_match (" %n => %e", name, &expr2); + if (m == MATCH_YES) + { + expr1 = gfc_get_expr (); + expr1->expr_type = EXPR_VARIABLE; + expr1->where = expr2->where; + expr1->ref = gfc_copy_ref (expr2->ref); + if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false)) + { + m = MATCH_ERROR; + goto cleanup; + } + + sym = expr1->symtree->n.sym; + sym2 = expr2->symtree->n.sym; + + as = sym2->ts.type == BT_CLASS ? CLASS_DATA (sym2)->as : sym2->as; + if (expr2->expr_type != EXPR_VARIABLE + || !(as && as->type == AS_ASSUMED_RANK)) + gfc_error_now ("The SELECT RANK selector at %C must be an assumed " + "rank variable"); + + if (expr2->ts.type == BT_CLASS) + { + copy_ts_from_selector_to_associate (expr1, expr2); + + sym->attr.flavor = FL_VARIABLE; + sym->attr.referenced = 1; + sym->attr.class_ok = 1; + CLASS_DATA (sym)->attr.allocatable = CLASS_DATA (sym2)->attr.allocatable; + CLASS_DATA (sym)->attr.pointer = CLASS_DATA (sym2)->attr.pointer; + CLASS_DATA (sym)->attr.target = CLASS_DATA (sym2)->attr.target; + sym->attr.pointer = 1; + } + else + { + sym->ts = sym2->ts; + sym->as = gfc_copy_array_spec (sym2->as); + sym->attr.dimension = 1; + + sym->attr.flavor = FL_VARIABLE; + sym->attr.referenced = 1; + sym->attr.class_ok = sym2->attr.class_ok; + sym->attr.allocatable = sym2->attr.allocatable; + sym->attr.pointer = sym2->attr.pointer; + sym->attr.target = sym2->attr.target; + } + } + else + { + m = gfc_match (" %e ", &expr1); + + if (m != MATCH_YES) + { + std::swap (ns, gfc_current_ns); + gfc_free_namespace (ns); + return m; + } + + sym = expr1->symtree->n.sym; + as = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as; + if (expr1->expr_type != EXPR_VARIABLE + || !(as && as->type == AS_ASSUMED_RANK)) + gfc_error_now ("The SELECT RANK selector at %C must be an assumed " + "rank variable"); + } + + m = gfc_match (" )%t"); + if (m != MATCH_YES) + { + gfc_error ("parse error in SELECT RANK statement at %C"); + goto cleanup; + } + + new_st.op = EXEC_SELECT_RANK; + new_st.expr1 = expr1; + new_st.expr2 = expr2; + new_st.ext.block.ns = gfc_current_ns; + + select_type_push (expr1->symtree->n.sym); + gfc_current_ns = ns; + + return MATCH_YES; + +cleanup: + gfc_free_expr (expr1); + gfc_free_expr (expr2); + gfc_undo_symbols (); + std::swap (ns, gfc_current_ns); + gfc_free_namespace (ns); + return m; +} + + /* Match a CASE statement. */ match @@ -6595,6 +6839,107 @@ cleanup: } +/* Match a RANK statement. */ + +match +gfc_match_rank_is (void) +{ + gfc_case *c = NULL; + match m; + int case_value; + + if (gfc_current_state () != COMP_SELECT_RANK) + { + gfc_error ("Unexpected RANK statement at %C"); + return MATCH_ERROR; + } + + if (gfc_match ("% default") == MATCH_YES) + { + m = match_case_eos (); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + new_st.op = EXEC_SELECT_RANK; + c = gfc_get_case (); + c->ts.type = BT_UNKNOWN; + c->where = gfc_current_locus; + new_st.ext.block.case_list = c; + select_type_stack->tmp = NULL; + return MATCH_YES; + } + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + c = gfc_get_case (); + c->where = gfc_current_locus; + c->ts = select_type_stack->selector->ts; + + m = gfc_match_expr (&c->low); + if (m == MATCH_NO) + { + if (gfc_match_char ('*') == MATCH_YES) + c->low = gfc_get_int_expr (gfc_default_integer_kind, + NULL, -1); + else + goto syntax; + + case_value = -1; + } + else if (m == MATCH_YES) + { + /* F2018: R1150 */ + if (c->low->expr_type != EXPR_CONSTANT + || c->low->ts.type != BT_INTEGER + || c->low->rank) + { + gfc_error ("The SELECT RANK CASE expression at %C must be a " + "scalar, integer constant"); + goto cleanup; + } + + case_value = (int) mpz_get_si (c->low->value.integer); + /* F2018: C1151 */ + if ((case_value < 0) || (case_value > GFC_MAX_DIMENSIONS)) + { + gfc_error ("The value of the SELECT RANK CASE expression at " + "%C must not be less than zero or greater than %d", + GFC_MAX_DIMENSIONS); + goto cleanup; + } + } + else + goto cleanup; + + if (gfc_match_char (')') != MATCH_YES) + goto syntax; + + m = match_case_eos (); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + new_st.op = EXEC_SELECT_RANK; + new_st.ext.block.case_list = c; + + /* Create temporary variable. Recycle the select type code. */ + select_rank_set_tmp (&c->ts, &case_value); + + return MATCH_YES; + +syntax: + gfc_error ("Syntax error in RANK specification at %C"); + +cleanup: + if (c != NULL) + gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */ + return MATCH_ERROR; +} + /********************* WHERE subroutines ********************/ /* Match the rest of a simple WHERE statement that follows an IF statement. diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 29854ee9000..1bd78b14338 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -121,6 +121,8 @@ match gfc_match_select (void); match gfc_match_select_type (void); match gfc_match_type_is (void); match gfc_match_class_is (void); +match gfc_match_select_rank (void); +match gfc_match_rank_is (void); match gfc_match_where (gfc_statement *); match gfc_match_elsewhere (void); match gfc_match_forall (gfc_statement *); diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 8950b6ac98f..caea16b9f5f 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -426,6 +426,7 @@ decode_statement (void) match (NULL, gfc_match_critical, ST_CRITICAL); match (NULL, gfc_match_select, ST_SELECT_CASE); match (NULL, gfc_match_select_type, ST_SELECT_TYPE); + match (NULL, gfc_match_select_rank, ST_SELECT_RANK); /* General statement matching: Instead of testing every possible statement, we eliminate most possibilities by peeking at the @@ -546,6 +547,7 @@ decode_statement (void) break; case 'r': + match ("rank", gfc_match_rank_is, ST_RANK); match ("read", gfc_match_read, ST_READ); match ("return", gfc_match_return, ST_RETURN); match ("rewind", gfc_match_rewind, ST_REWIND); @@ -1537,7 +1539,7 @@ next_statement (void) #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \ case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \ case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \ - case ST_OMP_PARALLEL: \ + case ST_SELECT_RANK: case ST_OMP_PARALLEL: \ case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \ case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \ case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \ @@ -2077,12 +2079,18 @@ gfc_ascii_statement (gfc_statement st) case ST_SELECT_TYPE: p = "SELECT TYPE"; break; + case ST_SELECT_RANK: + p = "SELECT RANK"; + break; case ST_TYPE_IS: p = "TYPE IS"; break; case ST_CLASS_IS: p = "CLASS IS"; break; + case ST_RANK: + p = "RANK"; + break; case ST_SEQUENCE: p = "SEQUENCE"; break; @@ -4179,7 +4187,7 @@ parse_select_block (void) reject_statement (); } - /* At this point, we're got a nonempty select block. */ + /* At this point, we've got a nonempty select block. */ cp = new_level (cp); *cp = new_st; @@ -4263,7 +4271,7 @@ parse_select_type_block (void) reject_statement (); } - /* At this point, we're got a nonempty select block. */ + /* At this point, we've got a nonempty select block. */ cp = new_level (cp); *cp = new_st; @@ -4306,6 +4314,81 @@ done: } +/* Parse a SELECT RANK construct. */ + +static void +parse_select_rank_block (void) +{ + gfc_statement st; + gfc_code *cp; + gfc_state_data s; + + gfc_current_ns = new_st.ext.block.ns; + accept_statement (ST_SELECT_RANK); + + cp = gfc_state_stack->tail; + push_state (&s, COMP_SELECT_RANK, gfc_new_block); + + /* Make sure that the next statement is a RANK IS or RANK DEFAULT. */ + for (;;) + { + st = next_statement (); + if (st == ST_NONE) + unexpected_eof (); + if (st == ST_END_SELECT) + /* Empty SELECT CASE is OK. */ + goto done; + if (st == ST_RANK) + break; + + gfc_error ("Expected RANK or RANK DEFAULT " + "following SELECT RANK at %C"); + + reject_statement (); + } + + /* At this point, we've got a nonempty select block. */ + cp = new_level (cp); + *cp = new_st; + + accept_statement (st); + + do + { + st = parse_executable (ST_NONE); + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_RANK: + cp = new_level (gfc_state_stack->head); + *cp = new_st; + gfc_clear_new_st (); + + accept_statement (st); + /* Fall through */ + + case ST_END_SELECT: + break; + + /* Can't have an executable statement because of + parse_executable(). */ + default: + unexpected_statement (st); + break; + } + } + while (st != ST_END_SELECT); + +done: + pop_state (); + accept_statement (st); + gfc_current_ns = gfc_current_ns->parent; + select_type_pop (); +} + + /* Given a symbol, make sure it is not an iteration variable for a DO statement. This subroutine is called when the symbol is seen in a context that causes it to become redefined. If the symbol is an @@ -5360,6 +5443,10 @@ parse_executable (gfc_statement st) parse_select_type_block (); break; + case ST_SELECT_RANK: + parse_select_rank_block (); + break; + case ST_DO: parse_do_block (); if (check_do_closure () == 1) @@ -6410,7 +6497,7 @@ done: if (flag_dump_fortran_global) gfc_dump_global_symbols (stdout); - + gfc_end_source_files (); return true; diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index 800f2f44114..58c2c1b9677 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -30,7 +30,8 @@ enum gfc_compile_state COMP_DERIVED_CONTAINS, COMP_BLOCK, COMP_ASSOCIATE, COMP_IF, COMP_STRUCTURE, COMP_UNION, COMP_MAP, COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM, - COMP_SELECT_TYPE, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL, COMP_DO_CONCURRENT + COMP_SELECT_TYPE, COMP_SELECT_RANK, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL, + COMP_DO_CONCURRENT }; /* Stack element for the current compilation state. These structures diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 1f48045d8fe..383ba442f42 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); diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c index ade2fce06a5..ee18d7aea8a 100644 --- a/gcc/fortran/st.c +++ b/gcc/fortran/st.c @@ -141,6 +141,7 @@ gfc_free_statement (gfc_code *p) case EXEC_SELECT: case EXEC_SELECT_TYPE: + case EXEC_SELECT_RANK: if (p->ext.block.case_list) gfc_free_case_list (p->ext.block.case_list); break; diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index c8d74e588dd..da7030192f5 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -3609,7 +3609,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr, if (ar->dimen == 0) { - gcc_assert (ar->codimen); + gcc_assert (ar->codimen || sym->attr.select_rank_temporary); if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr))) se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr)); @@ -7758,6 +7758,12 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_conv_descriptor_offset_get (desc)); } + else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)) + && !se->data_not_needed + && gfc_expr_attr (expr).select_rank_temporary) + { + gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node); + } else if (onebased && (!rank_remap || se->use_offset) && expr->symtree && !(expr->symtree->n.sym && expr->symtree->n.sym->ts.type == BT_CLASS diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 360688073c9..856a171abf4 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -1641,6 +1641,48 @@ class_has_len_component (gfc_symbol *sym) } +static void +copy_descriptor (stmtblock_t *block, tree dst, tree src, int rank) +{ + int n; + tree dim; + tree tmp; + tree tmp2; + tree size; + tree offset; + + offset = gfc_index_zero_node; + + /* Use memcpy to copy the descriptor. The size is the minimum of + the sizes of 'src' and 'dst'. This avoids a non-trivial conversion. */ + tmp = TYPE_SIZE_UNIT (TREE_TYPE (src)); + tmp2 = TYPE_SIZE_UNIT (TREE_TYPE (dst)); + size = fold_build2_loc (input_location, MIN_EXPR, + TREE_TYPE (tmp), tmp, tmp2); + tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); + tmp = build_call_expr_loc (input_location, tmp, 3, + gfc_build_addr_expr (NULL_TREE, dst), + gfc_build_addr_expr (NULL_TREE, src), + fold_convert (size_type_node, size)); + gfc_add_expr_to_block (block, tmp); + + /* Set the offset correctly. */ + for (n = 0; n < rank; n++) + { + dim = gfc_rank_cst[n]; + tmp = gfc_conv_descriptor_lbound_get (src, dim); + tmp2 = gfc_conv_descriptor_stride_get (src, dim); + tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), + tmp, tmp2); + offset = fold_build2_loc (input_location, MINUS_EXPR, + TREE_TYPE (offset), offset, tmp); + offset = gfc_evaluate_now (offset, block); + } + + gfc_conv_descriptor_offset_set (block, dst, offset); +} + + /* Do proper initialization for ASSOCIATE names. */ static void @@ -1658,6 +1700,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) bool need_len_assign; bool whole_array = true; gfc_ref *ref; + gfc_symbol *sym2; gcc_assert (sym->assoc); e = sym->assoc->target; @@ -1690,12 +1733,140 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) && e->ts.u.derived->attr.unlimited_polymorphic)) && (sym->ts.type == BT_CHARACTER || ((sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED) - && class_has_len_component (sym)))); + && class_has_len_component (sym))) + && !sym->attr.select_rank_temporary); + /* Do a `pointer assignment' with updated descriptor (or assign descriptor to array temporary) for arrays with either unknown shape or if associating - to a variable. */ - if (sym->attr.dimension && !class_target - && (sym->as->type == AS_DEFERRED || sym->assoc->variable)) + to a variable. Select rank temporaries need somewhat different treatment + to other associate names and case temporaries. This because the selector + is assumed rank and so the offset in particular has to be changed. Also, + the case temporaries carry both allocatable and target attributes if + present in the selector. This means that an allocatation or change of + association can occur and so has to be dealt with. */ + if (sym->attr.select_rank_temporary) + { + gfc_se se; + tree class_decl = NULL_TREE; + int rank = 0; + bool class_ptr; + + sym2 = e->symtree->n.sym; + gfc_init_se (&se, NULL); + if (e->ts.type == BT_CLASS) + { + /* Go straight to the class data. */ + if (sym2->attr.dummy) + { + class_decl = DECL_LANG_SPECIFIC (sym2->backend_decl) ? + GFC_DECL_SAVED_DESCRIPTOR (sym2->backend_decl) : + sym2->backend_decl; + if (POINTER_TYPE_P (TREE_TYPE (class_decl))) + class_decl = build_fold_indirect_ref_loc (input_location, + class_decl); + gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (class_decl))); + se.expr = gfc_class_data_get (class_decl); + } + else + { + class_decl = sym2->backend_decl; + gfc_conv_expr_descriptor (&se, e); + if (POINTER_TYPE_P (TREE_TYPE (se.expr))) + se.expr = build_fold_indirect_ref_loc (input_location, + se.expr); + } + + if (CLASS_DATA (sym)->as && CLASS_DATA (sym)->as->rank > 0) + rank = CLASS_DATA (sym)->as->rank; + } + else + { + gfc_conv_expr_descriptor (&se, e); + if (sym->as && sym->as->rank > 0) + rank = sym->as->rank; + } + + desc = sym->backend_decl; + + /* The SELECT TYPE mechanisms turn class temporaries into pointers, which + point to the selector. */ + class_ptr = class_decl != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (desc)); + if (class_ptr) + { + tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (desc)), "class"); + tmp = gfc_build_addr_expr (NULL, tmp); + gfc_add_modify (&se.pre, desc, tmp); + + tmp = gfc_class_vptr_get (class_decl); + gfc_add_modify (&se.pre, gfc_class_vptr_get (desc), tmp); + if (UNLIMITED_POLY (sym)) + gfc_add_modify (&se.pre, gfc_class_len_get (desc), + gfc_class_len_get (class_decl)); + + desc = gfc_class_data_get (desc); + } + + /* SELECT RANK temporaries can carry the allocatable and pointer + attributes so the selector descriptor must be copied in and + copied out. */ + if (rank > 0) + copy_descriptor (&se.pre, desc, se.expr, rank); + else + { + tmp = gfc_conv_descriptor_data_get (se.expr); + gfc_add_modify (&se.pre, desc, + fold_convert (TREE_TYPE (desc), tmp)); + } + + /* Deal with associate_name => selector. Class associate names are + treated in the same way as in SELECT TYPE. */ + sym2 = sym->assoc->target->symtree->n.sym; + if (sym2->assoc && sym->assoc->target && sym2->ts.type != BT_CLASS) + { + sym2 = sym2->assoc->target->symtree->n.sym; + se.expr = sym2->backend_decl; + + if (POINTER_TYPE_P (TREE_TYPE (se.expr))) + se.expr = build_fold_indirect_ref_loc (input_location, + se.expr); + } + + /* There could have been reallocation. Copy descriptor back to the + selector and update the offset. */ + if (sym->attr.allocatable || sym->attr.pointer + || (sym->ts.type == BT_CLASS + && (CLASS_DATA (sym)->attr.allocatable + || CLASS_DATA (sym)->attr.pointer))) + { + if (rank > 0) + copy_descriptor (&se.post, se.expr, desc, rank); + else + { + tmp = gfc_conv_descriptor_data_get (desc); + gfc_conv_descriptor_data_set (&se.post, se.expr, tmp); + } + + /* The dynamic type could have changed too. */ + if (sym->ts.type == BT_CLASS) + { + tmp = sym->backend_decl; + if (class_ptr) + tmp = build_fold_indirect_ref_loc (input_location, tmp); + gfc_add_modify (&se.post, gfc_class_vptr_get (class_decl), + gfc_class_vptr_get (tmp)); + if (UNLIMITED_POLY (sym)) + gfc_add_modify (&se.post, gfc_class_len_get (class_decl), + gfc_class_len_get (tmp)); + } + } + + tmp = gfc_finish_block (&se.post); + + gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), tmp); + } + /* Now all the other kinds of associate variable. */ + else if (sym->attr.dimension && !class_target + && (sym->as->type == AS_DEFERRED || sym->assoc->variable)) { gfc_se se; tree desc; @@ -3424,6 +3595,142 @@ gfc_trans_select_type (gfc_code * code) } +static tree +gfc_trans_select_rank_cases (gfc_code * code) +{ + gfc_code *c; + gfc_case *cp; + tree tmp; + tree cond; + tree low; + tree sexpr; + tree rank; + tree rank_minus_one; + tree minus_one; + gfc_se se; + gfc_se cse; + stmtblock_t block; + stmtblock_t body; + bool def = false; + + gfc_start_block (&block); + + /* Calculate the switch expression. */ + gfc_init_se (&se, NULL); + gfc_conv_expr_descriptor (&se, code->expr1); + rank = gfc_conv_descriptor_rank (se.expr); + rank = gfc_evaluate_now (rank, &block); + minus_one = build_int_cst (TREE_TYPE (rank), -1); + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + fold_convert (gfc_array_index_type, rank), + build_int_cst (gfc_array_index_type, 1)); + rank_minus_one = gfc_evaluate_now (tmp, &block); + tmp = gfc_conv_descriptor_ubound_get (se.expr, rank_minus_one); + cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + tmp, build_int_cst (TREE_TYPE (tmp), -1)); + tmp = fold_build3_loc (input_location, COND_EXPR, + TREE_TYPE (rank), cond, + rank, minus_one); + cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, + rank, build_int_cst (TREE_TYPE (rank), 0)); + sexpr = fold_build3_loc (input_location, COND_EXPR, + TREE_TYPE (rank), cond, + rank, tmp); + sexpr = gfc_evaluate_now (sexpr, &block); + TREE_USED (code->exit_label) = 0; + +repeat: + for (c = code->block; c; c = c->block) + { + cp = c->ext.block.case_list; + + /* Assume it's the default case. */ + low = NULL_TREE; + tmp = NULL_TREE; + + /* Put the default case at the end. */ + if ((!def && !cp->low) || (def && cp->low)) + continue; + + if (cp->low) + { + gfc_init_se (&cse, NULL); + gfc_conv_expr_val (&cse, cp->low); + gfc_add_block_to_block (&block, &cse.pre); + low = cse.expr; + } + + gfc_init_block (&body); + + /* Add the statements for this case. */ + tmp = gfc_trans_code (c->next); + gfc_add_expr_to_block (&body, tmp); + + /* Break to the end of the SELECT RANK construct. The default + case just falls through. */ + if (!def) + { + TREE_USED (code->exit_label) = 1; + tmp = build1_v (GOTO_EXPR, code->exit_label); + gfc_add_expr_to_block (&body, tmp); + } + + tmp = gfc_finish_block (&body); + + if (low != NULL_TREE) + { + cond = fold_build2_loc (input_location, EQ_EXPR, + TREE_TYPE (sexpr), sexpr, + fold_convert (TREE_TYPE (sexpr), low)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + cond, tmp, + build_empty_stmt (input_location)); + } + + gfc_add_expr_to_block (&block, tmp); + } + + if (!def) + { + def = true; + goto repeat; + } + + return gfc_finish_block (&block); +} + + +tree +gfc_trans_select_rank (gfc_code * code) +{ + stmtblock_t block; + tree body; + tree exit_label; + + gcc_assert (code && code->expr1); + gfc_init_block (&block); + + /* Build the exit label and hang it in. */ + exit_label = gfc_build_label_decl (NULL_TREE); + code->exit_label = exit_label; + + /* Empty SELECT constructs are legal. */ + if (code->block == NULL) + body = build_empty_stmt (input_location); + else + body = gfc_trans_select_rank_cases (code); + + /* Build everything together. */ + gfc_add_expr_to_block (&block, body); + + if (TREE_USED (exit_label)) + gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label)); + + return gfc_finish_block (&block); +} + + /* Traversal function to substitute a replacement symtree if the symbol in the expression is the same as that passed. f == 2 signals that that variable itself is not to be checked - only the references. diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h index 9cb0f68a637..967f7791681 100644 --- a/gcc/fortran/trans-stmt.h +++ b/gcc/fortran/trans-stmt.h @@ -53,6 +53,7 @@ tree gfc_trans_do_concurrent (gfc_code *); tree gfc_trans_do_while (gfc_code *); tree gfc_trans_select (gfc_code *); tree gfc_trans_select_type (gfc_code *); +tree gfc_trans_select_rank (gfc_code *); tree gfc_trans_sync (gfc_code *, gfc_exec_op); tree gfc_trans_lock_unlock (gfc_code *, gfc_exec_op); tree gfc_trans_event_post_wait (gfc_code *, gfc_exec_op); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 583f6e3b25b..2f878f6b118 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1968,6 +1968,10 @@ trans_code (gfc_code * code, tree cond) res = gfc_trans_select_type (code); break; + case EXEC_SELECT_RANK: + res = gfc_trans_select_rank (code); + break; + case EXEC_FLUSH: res = gfc_trans_flush (code); break; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index aa733125a03..308e4735c1c 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2019-09-01 Paul Thomas + + * gfortran.dg/select_rank_1.f90 : New test. + * gfortran.dg/select_rank_2.f90 : New test. + 2019-09-01 Jakub Jelinek PR middle-end/91623 diff --git a/gcc/testsuite/gfortran.dg/select_rank_1.f90 b/gcc/testsuite/gfortran.dg/select_rank_1.f90 new file mode 100644 index 00000000000..69f66556a6a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/select_rank_1.f90 @@ -0,0 +1,179 @@ +! { dg-do run } +! +! Basic tests of SELECT RANK +! +! Contributed by Paul Thomas +! + implicit none + type mytype + real :: r + end type + type, extends(mytype) :: thytype + integer :: i + end type + +! Torture using integers +ints: block + integer, dimension(2,2) :: y = reshape ([1,2,3,4],[2,2]) + integer, dimension(4) :: z = [1,2,3,4] + integer, dimension(2,2,2) :: q = reshape ([11,12,13,14,15,16,17,18],[2,2,2]) + integer :: i = 42 + + call ifoo(y, "y") + if (any (y .ne. reshape ([10,11,12,13], [2,2]))) stop 1 + call ifoo(z, "z") + call ifoo(i, "i") + call ifoo(q, "q") + if (any (q .ne. reshape ([11,12,10,11,15,16,12,13], [2,2,2]))) stop 2 + call ibar(y) +end block ints + +! Check derived types +types: block + integer :: i + type(mytype), allocatable, dimension(:,:) :: t + type(mytype), allocatable :: u + + allocate (t, source = reshape ([(mytype(real(i)), i = 1,4)],[2,2])) + call tfoo(t, "t") + if (any (size (t) .ne. [1,1])) stop 3 ! 't' has been reallocated! + if (abs (t(1,1)%r - 42.0) .ge. 1e-6) stop 4 + allocate (u, source = mytype(42.0)) + call tfoo(u, "u") +end block types + +! Check classes +classes: block + integer :: i + class(mytype), allocatable, dimension(:,:) :: v + class(mytype), allocatable :: w + + allocate (v, source = reshape ([(mytype(real(i)), i = 1,4)],[2,2])) + call cfoo(v, "v") + select type (v) + type is (mytype) + stop 5 + type is (thytype) + if (any (ubound (v) .ne. [3,3])) stop 6 + if (any (abs (v%r - 99.0) .ge. 1e-6)) stop 7 + if (any (v%i .ne. 42)) stop 8 + end select + allocate (w, source = thytype(42.0, 99)) + call cfoo(w, "w") +end block classes + +! Check unlimited polymorphic. +unlimited: block + integer(4) :: i + class(*), allocatable, dimension(:,:,:) :: v + + allocate (v, source = reshape ([(i, i = 1,8)],[2,2,2])) + call ufoo(v, "v") + select type (v) + type is (integer(4)) + stop 9 + type is (real(4)) + if (any (ubound(v) .ne. [2,2,1])) stop 10 + if (abs (sum (v) - 10.0) .gt. 1e-6) stop 11 + end select +end block unlimited + +contains + + recursive subroutine ifoo(w, chr) + integer, dimension(..) :: w + character(1) :: chr + + OUTER: select rank (x => w) + rank (2) + if ((chr .eq. 'y') .and. (any (x(1,:) .ne. [1,3]))) stop 12 + if ((chr .eq. 'r') .and. (any (x(1,:) .ne. [13,17]))) stop 13 + x = reshape ([10,11,12,13], [2,2]) + rank (0) + if ((chr .eq. 'i') .and. (x .ne. 42)) stop 14 + rank (*) + if ((chr .eq. 'w') .and. (any (x(1:4) .ne. [10,11,12,13]))) stop 15 + rank default + if ((chr .eq. 'z') .and. (rank (x) .ne. 1)) stop 16 + if ((chr .eq. 'q') .and. (rank (x) .ne. 3)) stop 17 + INNER: select rank (x) + rank (1) INNER + if ((chr .eq. 'z') .and. (any (x(1:4) .ne. [1,2,3,4]))) stop 18 + rank (3) INNER + ! Pass a rank 2 section otherwise an infinite loop ensues. + call ifoo(x(:,2,:), 'r') + end select INNER + end select OUTER + end subroutine ifoo + + subroutine ibar(x) + integer, dimension(*) :: x + + call ifoo(x, "w") + end subroutine ibar + + subroutine tfoo(w, chr) + type(mytype), dimension(..), allocatable :: w + character(1) :: chr + integer :: i + type(mytype), dimension(2,2) :: r + + select rank (x => w) + rank (2) + if (chr .eq. 't') then + r = reshape ([(mytype(real(i)), i = 1,4)],[2,2]) + if (any (abs (x%r - r%r) .gt. 1e-6)) stop 19 + if (allocated (x)) deallocate (x) + allocate (x(1,1)) + x(1,1) = mytype (42.0) + end if + rank default + if ((chr .eq. 'u') .and. (rank (x) .ne. 0)) stop 20 + end select + end subroutine tfoo + + subroutine cfoo(w, chr) + class(mytype), dimension(..), allocatable :: w + character(1) :: chr + integer :: i + type(mytype), dimension(2,2) :: r + + select rank (c => w) + rank (2) + select type (c) + type is (mytype) + if (chr .eq. 'v') then + r = reshape ([(mytype(real(i)), i = 1,4)],[2,2]) + if (any (abs (c%r - r%r) .gt. 1e-6)) stop 21 + end if + class default + stop 22 + end select + if (allocated (c)) deallocate (c) + allocate (c(3,3), source = thytype (99.0, 42)) + rank default + if ((chr .eq. 'w') .and. (rank (c) .ne. 0)) stop 23 + end select + end subroutine cfoo + + subroutine ufoo(w, chr) + class(*), dimension(..), allocatable :: w + character(1) :: chr + integer :: i + + select rank (c => w) + rank (3) + select type (c) + type is (integer(4)) + if (chr .eq. 'v' .and. (sum (c) .ne. 36)) stop 24 + class default + stop 25 + end select + if (allocated (c)) deallocate(c) + allocate (c, source = reshape ([(real(i), i = 1,4)],[2,2,1])) + rank default + stop 26 + end select + end subroutine ufoo + +end diff --git a/gcc/testsuite/gfortran.dg/select_rank_2.f90 b/gcc/testsuite/gfortran.dg/select_rank_2.f90 new file mode 100644 index 00000000000..2415fdff90c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/select_rank_2.f90 @@ -0,0 +1,85 @@ +! { dg-do compile } +! +! Basic tests of SELECT RANK +! +! Contributed by Paul Thomas +! +subroutine foo1 (arg) + integer :: i + integer, dimension(3) :: arg + select rank (arg) ! { dg-error "must be an assumed rank variable" } + rank (3) + print *, arg + end select +end + +subroutine foo2 (arg) + integer :: i + integer, dimension(..) :: arg + select rank (arg) + rank (i) ! { dg-error "must be a scalar" } + print *, arg ! { dg-error "Expected RANK or RANK DEFAULT" } + end select +end + +subroutine foo3 (arg) + integer :: i + integer, parameter :: r = 3 + integer, dimension(..) :: arg + select rank (arg) + rank (16) ! { dg-error "must not be less than zero or greater than 15" } + print *, arg ! { dg-error "Expected RANK or RANK DEFAULT" } + rank (-1) ! { dg-error "must not be less than zero or greater than 15" } + print *, arg ! { dg-error "Expected RANK or RANK DEFAULT" } + rank (r) ! OK + print *, arg + end select +end + +subroutine foo4 (arg) + integer :: i + integer, dimension(..), pointer :: arg + select rank (arg) ! { dg-error "cannot be used with the pointer or allocatable selector" } + rank (*) ! { dg-error "cannot be used with the pointer or allocatable selector" } + print *, arg(1:1) + rank (1) + print *, arg + end select +end + +subroutine foo5 (arg) + integer :: i + integer, dimension(..), ALLOCATABLE :: arg + select rank (arg) ! { dg-error "cannot be used with the pointer or allocatable selector" } + rank (*) ! { dg-error "pointer or allocatable selector|deferred shape or assumed rank" } + print *, arg(1:1) + rank (1) + print *, arg + end select +end + +subroutine foo6 (arg) + integer :: i + integer, dimension(..) :: arg + select rank (arg) + rank (*) + print *, arg ! { dg-error "assumed.size array" } + rank (1) + print *, arg + end select +end + +subroutine foo7 (arg) + integer :: i + integer, dimension(..) :: arg + select rank (arg) + rank (1) ! { dg-error "is repeated" } + arg = 1 + rank (1) ! { dg-error "is repeated" } + arg = 1 + rank (*) ! { dg-error "is repeated" } + rank (*) ! { dg-error "is repeated" } + rank default ! { dg-error "is repeated" } + rank default ! { dg-error "is repeated" } + end select +end -- 2.30.2