===================================================================
*************** spec_dimen_size (gfc_array_spec *as, int
gfc_internal_error ("spec_dimen_size(): Bad dimension");
if (as->type != AS_EXPLICIT
! || 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)
gfc_internal_error ("spec_dimen_size(): Bad dimension");
if (as->type != AS_EXPLICIT
! || !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)
===================================================================
*************** 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;
===================================================================
*************** show_symbol (gfc_symbol *sym)
show_expr (sym->value);
}
! if (sym->as)
{
show_indent ();
fputs ("Array spec:", dumpfile);
show_array_spec (sym->as);
}
if (sym->generic)
{
show_expr (sym->value);
}
! 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)
{
*************** show_code_node (int level, gfc_code *c)
case EXEC_SELECT:
case EXEC_SELECT_TYPE:
d = c->block;
! 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)
{
code_indent (level, 0);
-
fputs ("CASE ", dumpfile);
for (cp = d->ext.block.case_list; cp; cp = cp->next)
{
case EXEC_SELECT:
case EXEC_SELECT_TYPE:
+ case EXEC_SELECT_RANK:
d = c->block;
! 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);
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)
{
*************** show_code_node (int level, gfc_code *c)
fputc (')', dumpfile);
fputc (' ', dumpfile);
}
- fputc ('\n', dumpfile);
show_code (level + 1, d->next);
}
code_indent (level, c->label1);
fputc (')', dumpfile);
fputc (' ', dumpfile);
}
show_code (level + 1, d->next);
+ fputc ('\n', dumpfile);
}
code_indent (level, c->label1);
===================================================================
*************** gfc_check_vardef_context (gfc_expr* e, b
}
}
/* Check variable definition context for associate-names. */
! if (!pointer && sym->assoc)
{
const char* name;
gfc_association_list* assoc;
}
}
/* Check variable definition context for associate-names. */
! if (!pointer && sym->assoc && !sym->attr.select_rank_temporary)
{
const char* name;
gfc_association_list* assoc;
===================================================================
*************** 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_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,
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_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,
*************** 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;
/* These are the attributes required for parameterized derived
types. */
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/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. */
*************** 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_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,
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_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,
===================================================================
*************** match_exit_cycle (gfc_statement st, gfc_
case COMP_IF:
case COMP_SELECT:
case COMP_SELECT_TYPE:
+ case COMP_SELECT_RANK:
gcc_assert (sym);
if (op == EXEC_CYCLE)
{
*************** copy_ts_from_selector_to_associate (gfc_
ref = ref->next;
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
ref = ref->next;
if (selector->ts.type == BT_CLASS && CLASS_DATA (selector)->as
! && 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
*************** copy_ts_from_selector_to_associate (gfc_
else
assoc_sym->as = NULL;
+ build_class_sym:
if (selector->ts.type == BT_CLASS)
{
/* The correct class container has to be available. */
*************** select_intrinsic_set_tmp (gfc_typespec *
char name[GFC_MAX_SYMBOL_LEN];
gfc_symtree *tmp;
HOST_WIDE_INT charlen = 0;
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)
return NULL;
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);
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 (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);
*************** select_intrinsic_set_tmp (gfc_typespec *
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",
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);
/* 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))
! {
! 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);
! }
!
! 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;
return tmp;
}
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",
gfc_basic_typename (ts->type), charlen, ts->kind);
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
! && (CLASS_DATA (selector)->attr.dimension
! || CLASS_DATA (selector)->attr.codimension))
! {
! 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 (sym);
! gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL);
! sym->attr.select_type_temporary = 1;
return tmp;
}
*************** 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)
{
*************** 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);
! if (select_type_stack->selector->ts.type == BT_CLASS
! && select_type_stack->selector->attr.class_ok)
{
! tmp->n.sym->attr.pointer
! = CLASS_DATA (select_type_stack->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)
{
! 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);
}
! }
! 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;
! if (ts->type == BT_CLASS)
! gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
! &tmp->n.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. */
! tmp->n.sym->assoc = gfc_get_association_list ();
! tmp->n.sym->assoc->dangling = 1;
! tmp->n.sym->assoc->st = tmp;
select_type_stack->tmp = tmp;
}
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);
! sym = tmp->n.sym;
! gfc_add_type (sym, ts, NULL);
! if (selector->ts.type == BT_CLASS && selector->attr.class_ok)
{
! sym->attr.pointer
! = CLASS_DATA (selector)->attr.class_pointer;
/* Copy across the array spec to the selector. */
! if (CLASS_DATA (selector)->attr.dimension
! || CLASS_DATA (selector)->attr.codimension)
{
! 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 (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 (&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. */
! sym->assoc = gfc_get_association_list ();
! sym->assoc->dangling = 1;
! sym->assoc->st = tmp;
select_type_stack->tmp = tmp;
}
*************** 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
*************** 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.
===================================================================
*************** 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 *);
===================================================================
*************** 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
*************** 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);
*************** 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_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: \
#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_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: \
*************** 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;
*************** 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're 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_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)
===================================================================
*************** 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
};
/* Stack element for the current compilation state. These structures
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_SELECT_RANK, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL,
! COMP_DO_CONCURRENT
};
/* Stack element for the current compilation state. These structures
===================================================================
*************** resolve_procedure_expression (gfc_expr*
/* Check that name is not a derived type. */
!
static bool
is_dt_name (const char *name)
{
/* Check that name is not a derived type. */
!
static bool
is_dt_name (const char *name)
{
*************** 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))
! {
! if (!actual_arg)
{
gfc_error ("Assumed-rank variable %s at %L may only be used as "
"actual argument", sym->name, &e->where);
}
}
/* 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))
! && !sym->attr.select_rank_temporary)
! {
! 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);
*************** gfc_resolve_expr (gfc_expr *e)
bool t;
bool inquiry_save, actual_arg_save, first_actual_arg_save;
! if (e == NULL)
return true;
/* inquiry_argument only applies to variables. */
bool t;
bool inquiry_save, actual_arg_save, first_actual_arg_save;
! if (e == NULL || e->do_not_resolve_again)
return true;
/* inquiry_argument only applies to variables. */
*************** 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;
}
*************** resolve_assoc_var (gfc_symbol* sym, bool
if (target->ts.type == BT_CLASS)
gfc_fix_class_refs (target);
! if (target->rank != 0)
{
gfc_array_spec *as;
/* The rank may be incorrectly guessed at parsing, therefore make sure
if (target->ts.type == BT_CLASS)
gfc_fix_class_refs (target);
! if (target->rank != 0 && !sym->attr.select_rank_temporary)
{
gfc_array_spec *as;
/* The rank may be incorrectly guessed at parsing, therefore make sure
*************** resolve_assoc_var (gfc_symbol* sym, bool
CLASS_DATA (sym)->attr.codimension = 1;
}
}
! else
{
/* target's rank is 0, but the type of the sym is still array valued,
which has to be corrected. */
CLASS_DATA (sym)->attr.codimension = 1;
}
}
! 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_select_type (gfc_code *code, gfc
}
+ /* 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
*************** gfc_resolve_blocks (gfc_code *b, gfc_nam
case EXEC_SELECT:
case EXEC_SELECT_TYPE:
+ case EXEC_SELECT_RANK:
case EXEC_FORALL:
case EXEC_DO:
case EXEC_DO_WHILE:
*************** 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;
*************** resolve_typebound_procedure (gfc_symtree
}
else
{
! /* 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)
}
else
{
! /* 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)
*************** resolve_symbol (gfc_symbol *sym)
}
/* TS 29113, C535a. */
if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy
! && !sym->attr.select_type_temporary)
{
gfc_error ("Assumed-rank array at %L must be a dummy argument",
&sym->declared_at);
}
/* TS 29113, C535a. */
if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy
! && !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);
===================================================================
*************** 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;
===================================================================
*************** gfc_conv_array_ref (gfc_se * se, gfc_arr
if (ar->dimen == 0)
{
! gcc_assert (ar->codimen);
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
if (ar->dimen == 0)
{
! 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_expr_descriptor (gfc_se *se, gf
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
===================================================================
*************** 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
*************** trans_associate_var (gfc_symbol *sym, gf
bool need_len_assign;
bool whole_array = true;
gfc_ref *ref;
+ gfc_symbol *sym2;
gcc_assert (sym->assoc);
e = sym->assoc->target;
*************** trans_associate_var (gfc_symbol *sym, gf
&& 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))));
/* 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))
{
gfc_se se;
tree desc;
&& 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)))
! && !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. 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;
*************** gfc_trans_select_type (gfc_code * 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);
+ }
+
+
+ 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));
===================================================================
*************** 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);
===================================================================
*************** 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;
===================================================================
***************
+ ! { 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
===================================================================
***************
+ ! { 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
When I started on this about three months ago, I thought that with SELECT TYPE as a template this was going to be low hanging fruit. Not so :-) Among the issues on the way were: class selectors; unlimited polymorphic selectors even more so; and error recovery. It's a good starting point but I am not holding my breath for it being PR-free. It will be noted that the select rank temporaries are also select type temporaries. This simplifies some of the logic, especially in resolution, and allows RANK DEFAULT to be handled in the same way as CLASS DEFAULT in trans-stmt.c. In the new function, trans-stmt.c(copy_descriptor), memcpy is used to copy-in/copy-out sections of the dim[] array between the case descriptor and the assumed rank selector. This avoids explicitly copying the bounds and strides or messing around trying to convert the types. There is maybe a better way to do this but I didn't find it. While I was about it, I made the code in some of the SELECT TYPE matching much more readable by using a gfc_symbol *selector = select_type_stack->selector. Bootstraps and regtests on FC29/x86_64 - OK for trunk? Now on to PDTs.... Paul 2019-08-31 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-31 Paul Thomas <pault@gcc.gnu.org> * gfortran.dg/select_rank_1.f90 : New test.