+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-08-30 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/91587
2019-08-27 Mark Eggleston <mark.eggleston@codethink.com>
* 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
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)
case COMP_SELECT:
case COMP_SELECT_TYPE:
+ case COMP_SELECT_RANK:
*st = ST_END_SELECT;
target = " select";
eos_ok = 0;
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)
{
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)
{
fputc (')', dumpfile);
fputc (' ', dumpfile);
}
- fputc ('\n', dumpfile);
show_code (level + 1, d->next);
+ fputc ('\n', dumpfile);
}
code_indent (level, c->label1);
}
}
/* 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;
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,
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. */
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,
case COMP_IF:
case COMP_SELECT:
case COMP_SELECT_TYPE:
+ case COMP_SELECT_RANK:
gcc_assert (sym);
if (op == EXEC_CYCLE)
{
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
else
assoc_sym->as = NULL;
+build_class_sym:
if (selector->ts.type == BT_CLASS)
{
/* The correct class container has to be available. */
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);
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;
}
{
char name[GFC_MAX_SYMBOL_LEN];
gfc_symtree *tmp = NULL;
+ gfc_symbol *selector = select_type_stack->selector;
+ gfc_symbol *sym;
if (!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;
}
}
+/* 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
}
+/* 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.
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 *);
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
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);
#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: \
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;
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;
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;
}
+/* 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
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)
if (flag_dump_fortran_global)
gfc_dump_global_symbols (stdout);
-
+
gfc_end_source_files ();
return true;
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
/* Check that name is not a derived type. */
-
+
static bool
is_dt_name (const char *name)
{
}
}
/* 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);
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. */
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;
}
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
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. */
}
+/* 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
case EXEC_SELECT:
case EXEC_SELECT_TYPE:
+ case EXEC_SELECT_RANK:
case EXEC_FORALL:
case EXEC_DO:
case EXEC_DO_WHILE:
resolve_select_type (code, ns);
break;
+ case EXEC_SELECT_RANK:
+ resolve_select_rank (code, ns);
+ break;
+
case EXEC_BLOCK:
resolve_block_construct (code);
break;
}
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)
}
/* 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);
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;
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));
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
}
+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
bool need_len_assign;
bool whole_array = true;
gfc_ref *ref;
+ gfc_symbol *sym2;
gcc_assert (sym->assoc);
e = sym->assoc->target;
&& 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;
}
+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.
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);
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;
+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.
+
2019-09-01 Jakub Jelinek <jakub@redhat.com>
PR middle-end/91623
--- /dev/null
+! { dg-do run }
+!
+! Basic tests of SELECT RANK
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+ 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
--- /dev/null
+! { dg-do compile }
+!
+! Basic tests of SELECT RANK
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+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
projects / gcc.git / commitdiff