mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-08 19:20:44 +08:00
Code Issues Packages Projects Releases Wiki Activity

array.c (spec_dimen_size): Check for the presence of expressions for the bounds.

Browse Source 
2019-09-01  Paul Thomas  <pault@gcc.gnu.org>

	* array.c (spec_dimen_size): Check for the presence of
	expressions for the bounds.
	* decl.c (gfc_match_end): Add case COMP_SELECT_RANK.
	* dump-parse-tree.c(show_symbol): Show the arrayspec of class
	entities.
	(show_code_node): Show the code for SELECT_RANK.
	* expr.c (gfc_check_vardef_context): Omit the context of
	variable definition for select rank associate names since the
	ASSUMED RANK throws.
	* gfortran.h : Add ST_SELECT_RANK and ST_RANK to enum
	gfc_statement. Add select_rank_temporary to symbol attribute
	structure. Add EXEC_SELECT_RANK to enum gfc_exec_op.
	* match.c (match_exit_cycle): Add COMP_SELECT_RANK.
	(copy_ts_from_selector_to_associate): Add as special case for
	assumed rank class variables.
	(select_intrinsic_set_tmp): Clean up the code by using symbols
	for references to the temporary and the selector.
	(select_type_set_tmp): Ditto.
	(select_rank_set_tmp): New function.
	(gfc_match_select_rank): New function.
	(gfc_match_rank_is): New function.
	* match.h : Add prototypes for gfc_match_select_rank and
	gfc_match_rank_is.
	* parse.c (decode_statement): Attempt to match select_rank and
	rank statements.
	(next_statement, gfc_ascii_statement): Add ST_SELECT_RANK.
	(parse_select_rank_block): New function.
	(parse_executable): Parse select rank block for ST_SELECT_RANK.
	* parse.h : Add COMP_SELECT_RANK to enum gfc_compile_state.
	* resolve.c (resolve_variable): Exclude select_rank_temporaries
	from the check on use of ASSUMED RANK.
	(gfc_resolve_expr): Make sure that unlimited polymorphic select
	rank temporaries expressions are not resolved again after being
	successfully resolved.
	(resolve_assoc_var): Do not do the rank check for select rank
	temporaries.
	(resolve_select_rank): New function.
	(gfc_resolve_blocks): Deal with case EXEC_SELECT_RANK.
	(resolve_symbol): Exclude select rank temporaries for check on
	use of ASSUMED RANK.
	* st.c (gfc_free_statement): Include EXEC_SELECT_RANK.
	* trans-array.c (gfc_conv_array_ref): Select rank temporaries
	may have dimen == 0.
	(gfc_conv_expr_descriptor): Zero the offset of select rank
	temporaries.
	* trans-stmt.c (copy_descriptor): New function.
	(trans_associate_var): Add code to associate select rank temps.
	(gfc_trans_select_rank_cases): New function.
	(gfc_trans_select_rank): New function.
	* trans-stmt.h : Add prototype for gfc_trans_select_rank.
	trans.c (trans_code): Add select rank case.


2019-09-01  Paul Thomas  <pault@gcc.gnu.org>

	* gfortran.dg/select_rank_1.f90 : New test.
	* gfortran.dg/select_rank_2.f90 : New test.

From-SVN: r275269
This commit is contained in:
Paul Thomas 2019-09-01 12:53:02 +00:00
parent 3e7254c5e4
commit 70570ec192
19 changed files with 1356 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
gcc/fortran/ChangeLog
View File

@ -1,3 +1,57 @@
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
@ -49,7 +103,7 @@
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

6
gcc/fortran/array.c
View File

@ -2213,7 +2213,11 @@ spec_dimen_size (gfc_array_spec *as, int dimen, mpz_t *result)
gfc_internal_error ("spec_dimen_size(): Bad dimension");
if (as->type != AS_EXPLICIT
|| as->lower[dimen]->expr_type != EXPR_CONSTANT
|| !as->lower[dimen]
|| !as->upper[dimen])
return false;
if (as->lower[dimen]->expr_type != EXPR_CONSTANT
|| as->upper[dimen]->expr_type != EXPR_CONSTANT
|| as->lower[dimen]->ts.type != BT_INTEGER
|| as->upper[dimen]->ts.type != BT_INTEGER)

1
gcc/fortran/decl.c
View File

@ -8164,6 +8164,7 @@ gfc_match_end (gfc_statement *st)
case COMP_SELECT:
case COMP_SELECT_TYPE:
case COMP_SELECT_RANK:
*st = ST_END_SELECT;
target = " select";
eos_ok = 0;

20
gcc/fortran/dump-parse-tree.c
View File

@ -1000,12 +1000,18 @@ show_symbol (gfc_symbol *sym)
show_expr (sym->value);
}
if (sym->as)
if (sym->ts.type != BT_CLASS && sym->as)
{
show_indent ();
fputs ("Array spec:", dumpfile);
show_array_spec (sym->as);
}
else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)
{
show_indent ();
fputs ("Array spec:", dumpfile);
show_array_spec (CLASS_DATA (sym)->as);
}
if (sym->generic)
{
@ -2168,18 +2174,22 @@ show_code_node (int level, gfc_code *c)
case EXEC_SELECT:
case EXEC_SELECT_TYPE:
case EXEC_SELECT_RANK:
d = c->block;
if (c->op == EXEC_SELECT_TYPE)
fputc ('\n', dumpfile);
code_indent (level, 0);
if (c->op == EXEC_SELECT_RANK)
fputs ("SELECT RANK ", dumpfile);
else if (c->op == EXEC_SELECT_TYPE)
fputs ("SELECT TYPE ", dumpfile);
else
fputs ("SELECT CASE ", dumpfile);
show_expr (c->expr1);
fputc ('\n', dumpfile);
for (; d; d = d->block)
{
fputc ('\n', dumpfile);
code_indent (level, 0);
fputs ("CASE ", dumpfile);
for (cp = d->ext.block.case_list; cp; cp = cp->next)
{
@ -2190,9 +2200,9 @@ show_code_node (int level, gfc_code *c)
fputc (')', dumpfile);
fputc (' ', dumpfile);
}
fputc ('\n', dumpfile);
show_code (level + 1, d->next);
fputc ('\n', dumpfile);
}
code_indent (level, c->label1);

2
gcc/fortran/expr.c
View File

@ -6181,7 +6181,7 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
}
}
/* Check variable definition context for associate-names. */
if (!pointer && sym->assoc)
if (!pointer && sym->assoc && !sym->attr.select_rank_temporary)
{
const char* name;
gfc_association_list* assoc;

12
gcc/fortran/gfortran.h
View File

@ -216,7 +216,7 @@ enum gfc_statement
ST_POINTER_ASSIGNMENT, ST_SELECT_CASE, ST_SEQUENCE, ST_SIMPLE_IF,
ST_STATEMENT_FUNCTION, ST_DERIVED_DECL, ST_LABEL_ASSIGNMENT, ST_ENUM,
ST_ENUMERATOR, ST_END_ENUM, ST_SELECT_TYPE, ST_TYPE_IS, ST_CLASS_IS,
ST_STRUCTURE_DECL, ST_END_STRUCTURE,
ST_SELECT_RANK, ST_RANK, ST_STRUCTURE_DECL, ST_END_STRUCTURE,
ST_UNION, ST_END_UNION, ST_MAP, ST_END_MAP,
ST_OACC_PARALLEL_LOOP, ST_OACC_END_PARALLEL_LOOP, ST_OACC_PARALLEL,
ST_OACC_END_PARALLEL, ST_OACC_KERNELS, ST_OACC_END_KERNELS, ST_OACC_DATA,
@ -894,9 +894,9 @@ typedef struct
event_comp:1, defined_assign_comp:1, unlimited_polymorphic:1,
has_dtio_procs:1, caf_token:1;
/* This is a temporary selector for SELECT TYPE or an associate
variable for SELECT_TYPE or ASSOCIATE. */
unsigned select_type_temporary:1, associate_var:1;
/* This is a temporary selector for SELECT TYPE/RANK or an associate
variable for SELECT TYPE/RANK or ASSOCIATE. */
unsigned select_type_temporary:1, select_rank_temporary:1, associate_var:1;
/* These are the attributes required for parameterized derived
types. */
@ -2555,8 +2555,8 @@ enum gfc_exec_op
EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_CONCURRENT, EXEC_DO_WHILE,
EXEC_SELECT, EXEC_BLOCK, EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT,
EXEC_CALL_PPC, EXEC_ALLOCATE, EXEC_DEALLOCATE, EXEC_END_PROCEDURE,
EXEC_SELECT_TYPE, EXEC_SYNC_ALL, EXEC_SYNC_MEMORY, EXEC_SYNC_IMAGES,
EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT,
EXEC_SELECT_TYPE, EXEC_SELECT_RANK, EXEC_SYNC_ALL, EXEC_SYNC_MEMORY,
EXEC_SYNC_IMAGES, EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT,
EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END,
EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH,
EXEC_FORM_TEAM, EXEC_CHANGE_TEAM, EXEC_END_TEAM, EXEC_SYNC_TEAM,

429
gcc/fortran/match.c
View File

@ -2825,6 +2825,7 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op)
case COMP_IF:
case COMP_SELECT:
case COMP_SELECT_TYPE:
case COMP_SELECT_RANK:
gcc_assert (sym);
if (op == EXEC_CYCLE)
{
@ -6065,7 +6066,14 @@ copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
ref = ref->next;
if (selector->ts.type == BT_CLASS && CLASS_DATA (selector)->as
&& ref && ref->type == REF_ARRAY)
&& CLASS_DATA (selector)->as->type == AS_ASSUMED_RANK)
{
assoc_sym->attr.dimension = 1;
assoc_sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as);
goto build_class_sym;
}
else if (selector->ts.type == BT_CLASS && CLASS_DATA (selector)->as
&& ref && ref->type == REF_ARRAY)
{
/* Ensure that the array reference type is set. We cannot use
gfc_resolve_expr at this point, so the usable parts of
@ -6116,6 +6124,7 @@ copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector)
else
assoc_sym->as = NULL;
build_class_sym:
if (selector->ts.type == BT_CLASS)
{
/* The correct class container has to be available. */
@ -6149,14 +6158,17 @@ select_intrinsic_set_tmp (gfc_typespec *ts)
char name[GFC_MAX_SYMBOL_LEN];
gfc_symtree *tmp;
HOST_WIDE_INT charlen = 0;
gfc_symbol *selector = select_type_stack->selector;
gfc_symbol *sym;
if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
return NULL;
if (select_type_stack->selector->ts.type == BT_CLASS
&& !select_type_stack->selector->attr.class_ok)
if (selector->ts.type == BT_CLASS && !selector->attr.class_ok)
return NULL;
/* Case value == NULL corresponds to SELECT TYPE cases otherwise
the values correspond to SELECT rank cases. */
if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length
&& ts->u.cl->length->expr_type == EXPR_CONSTANT)
charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
@ -6165,29 +6177,28 @@ select_intrinsic_set_tmp (gfc_typespec *ts)
sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type),
ts->kind);
else
snprintf (name, sizeof (name), "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
snprintf (name, sizeof (name),
"__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
gfc_basic_typename (ts->type), charlen, ts->kind);
gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
gfc_add_type (tmp->n.sym, ts, NULL);
sym = tmp->n.sym;
gfc_add_type (sym, ts, NULL);
/* Copy across the array spec to the selector. */
if (select_type_stack->selector->ts.type == BT_CLASS
&& (CLASS_DATA (select_type_stack->selector)->attr.dimension
|| CLASS_DATA (select_type_stack->selector)->attr.codimension))
if (selector->ts.type == BT_CLASS
&& (CLASS_DATA (selector)->attr.dimension
|| CLASS_DATA (selector)->attr.codimension))
{
tmp->n.sym->attr.pointer = 1;
tmp->n.sym->attr.dimension
= CLASS_DATA (select_type_stack->selector)->attr.dimension;
tmp->n.sym->attr.codimension
= CLASS_DATA (select_type_stack->selector)->attr.codimension;
tmp->n.sym->as
= gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
sym->attr.pointer = 1;
sym->attr.dimension = CLASS_DATA (selector)->attr.dimension;
sym->attr.codimension = CLASS_DATA (selector)->attr.codimension;
sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as);
}
gfc_set_sym_referenced (tmp->n.sym);
gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
tmp->n.sym->attr.select_type_temporary = 1;
gfc_set_sym_referenced (sym);
gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL);
sym->attr.select_type_temporary = 1;
return tmp;
}
@ -6200,6 +6211,8 @@ select_type_set_tmp (gfc_typespec *ts)
{
char name[GFC_MAX_SYMBOL_LEN];
gfc_symtree *tmp = NULL;
gfc_symbol *selector = select_type_stack->selector;
gfc_symbol *sym;
if (!ts)
{
@ -6218,42 +6231,45 @@ select_type_set_tmp (gfc_typespec *ts)
sprintf (name, "__tmp_class_%s", ts->u.derived->name);
else
sprintf (name, "__tmp_type_%s", ts->u.derived->name);
gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
gfc_add_type (tmp->n.sym, ts, NULL);
if (select_type_stack->selector->ts.type == BT_CLASS
&& select_type_stack->selector->attr.class_ok)
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)
{
tmp->n.sym->attr.pointer
= CLASS_DATA (select_type_stack->selector)->attr.class_pointer;
sym->attr.pointer
= CLASS_DATA (selector)->attr.class_pointer;
/* Copy across the array spec to the selector. */
if (CLASS_DATA (select_type_stack->selector)->attr.dimension
|| CLASS_DATA (select_type_stack->selector)->attr.codimension)
if (CLASS_DATA (selector)->attr.dimension
|| CLASS_DATA (selector)->attr.codimension)
{
tmp->n.sym->attr.dimension
= CLASS_DATA (select_type_stack->selector)->attr.dimension;
tmp->n.sym->attr.codimension
= CLASS_DATA (select_type_stack->selector)->attr.codimension;
tmp->n.sym->as
= gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
sym->attr.dimension
= CLASS_DATA (selector)->attr.dimension;
sym->attr.codimension
= CLASS_DATA (selector)->attr.codimension;
sym->as
= gfc_copy_array_spec (CLASS_DATA (selector)->as);
}
}
}
gfc_set_sym_referenced (tmp->n.sym);
gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
tmp->n.sym->attr.select_type_temporary = 1;
gfc_set_sym_referenced (sym);
gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL);
sym->attr.select_type_temporary = 1;
if (ts->type == BT_CLASS)
gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
&tmp->n.sym->as);
if (ts->type == BT_CLASS)
gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
}
else
sym = tmp->n.sym;
/* Add an association for it, so the rest of the parser knows it is
an associate-name. The target will be set during resolution. */
tmp->n.sym->assoc = gfc_get_association_list ();
tmp->n.sym->assoc->dangling = 1;
tmp->n.sym->assoc->st = tmp;
sym->assoc = gfc_get_association_list ();
sym->assoc->dangling = 1;
sym->assoc->st = tmp;
select_type_stack->tmp = tmp;
}
@ -6374,6 +6390,234 @@ cleanup:
}
/* Set the temporary for the current intrinsic SELECT RANK selector. */
static void
select_rank_set_tmp (gfc_typespec *ts, int *case_value)
{
char name[2 * GFC_MAX_SYMBOL_LEN];
char tname[GFC_MAX_SYMBOL_LEN];
gfc_symtree *tmp;
gfc_symbol *selector = select_type_stack->selector;
gfc_symbol *sym;
gfc_symtree *st;
HOST_WIDE_INT charlen = 0;
if (case_value == NULL)
return;
if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length
&& ts->u.cl->length->expr_type == EXPR_CONSTANT)
charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
if (ts->type == BT_CLASS)
sprintf (tname, "class_%s", ts->u.derived->name);
else if (ts->type == BT_DERIVED)
sprintf (tname, "type_%s", ts->u.derived->name);
else if (ts->type != BT_CHARACTER)
sprintf (tname, "%s_%d", gfc_basic_typename (ts->type), ts->kind);
else
sprintf (tname, "%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
gfc_basic_typename (ts->type), charlen, ts->kind);
/* Case value == NULL corresponds to SELECT TYPE cases otherwise
the values correspond to SELECT rank cases. */
if (*case_value >=0)
sprintf (name, "__tmp_%s_rank_%d", tname, *case_value);
else
sprintf (name, "__tmp_%s_rank_m%d", tname, -*case_value);
gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
if (st)
return;
gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
sym = tmp->n.sym;
gfc_add_type (sym, ts, NULL);
/* Copy across the array spec to the selector. */
if (selector->ts.type == BT_CLASS)
{
sym->ts.u.derived = CLASS_DATA (selector)->ts.u.derived;
sym->attr.pointer = CLASS_DATA (selector)->attr.pointer;
sym->attr.allocatable = CLASS_DATA (selector)->attr.allocatable;
sym->attr.target = CLASS_DATA (selector)->attr.target;
sym->attr.class_ok = 0;
if (case_value && *case_value != 0)
{
sym->attr.dimension = 1;
sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as);
if (*case_value > 0)
{
sym->as->type = AS_DEFERRED;
sym->as->rank = *case_value;
}
else if (*case_value == -1)
{
sym->as->type = AS_ASSUMED_SIZE;
sym->as->rank = 1;
}
}
}
else
{
sym->attr.pointer = selector->attr.pointer;
sym->attr.allocatable = selector->attr.allocatable;
sym->attr.target = selector->attr.target;
if (case_value && *case_value != 0)
{
sym->attr.dimension = 1;
sym->as = gfc_copy_array_spec (selector->as);
if (*case_value > 0)
{
sym->as->type = AS_DEFERRED;
sym->as->rank = *case_value;
}
else if (*case_value == -1)
{
sym->as->type = AS_ASSUMED_SIZE;
sym->as->rank = 1;
}
}
}
gfc_set_sym_referenced (sym);
gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL);
sym->attr.select_type_temporary = 1;
if (case_value)
sym->attr.select_rank_temporary = 1;
if (ts->type == BT_CLASS)
gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
/* Add an association for it, so the rest of the parser knows it is
an associate-name. The target will be set during resolution. */
sym->assoc = gfc_get_association_list ();
sym->assoc->dangling = 1;
sym->assoc->st = tmp;
select_type_stack->tmp = tmp;
}
/* Match a SELECT RANK statement. */
match
gfc_match_select_rank (void)
{
gfc_expr *expr1, *expr2 = NULL;
match m;
char name[GFC_MAX_SYMBOL_LEN];
gfc_symbol *sym, *sym2;
gfc_namespace *ns = gfc_current_ns;
gfc_array_spec *as;
m = gfc_match_label ();
if (m == MATCH_ERROR)
return m;
m = gfc_match (" select rank ( ");
if (m != MATCH_YES)
return m;
if (!gfc_notify_std (GFC_STD_F2018, "SELECT RANK statement at %C"))
return MATCH_NO;
gfc_current_ns = gfc_build_block_ns (ns);
m = gfc_match (" %n => %e", name, &expr2);
if (m == MATCH_YES)
{
expr1 = gfc_get_expr ();
expr1->expr_type = EXPR_VARIABLE;
expr1->where = expr2->where;
expr1->ref = gfc_copy_ref (expr2->ref);
if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
{
m = MATCH_ERROR;
goto cleanup;
}
sym = expr1->symtree->n.sym;
sym2 = expr2->symtree->n.sym;
as = sym2->ts.type == BT_CLASS ? CLASS_DATA (sym2)->as : sym2->as;
if (expr2->expr_type != EXPR_VARIABLE
|| !(as && as->type == AS_ASSUMED_RANK))
gfc_error_now ("The SELECT RANK selector at %C must be an assumed "
"rank variable");
if (expr2->ts.type == BT_CLASS)
{
copy_ts_from_selector_to_associate (expr1, expr2);
sym->attr.flavor = FL_VARIABLE;
sym->attr.referenced = 1;
sym->attr.class_ok = 1;
CLASS_DATA (sym)->attr.allocatable = CLASS_DATA (sym2)->attr.allocatable;
CLASS_DATA (sym)->attr.pointer = CLASS_DATA (sym2)->attr.pointer;
CLASS_DATA (sym)->attr.target = CLASS_DATA (sym2)->attr.target;
sym->attr.pointer = 1;
}
else
{
sym->ts = sym2->ts;
sym->as = gfc_copy_array_spec (sym2->as);
sym->attr.dimension = 1;
sym->attr.flavor = FL_VARIABLE;
sym->attr.referenced = 1;
sym->attr.class_ok = sym2->attr.class_ok;
sym->attr.allocatable = sym2->attr.allocatable;
sym->attr.pointer = sym2->attr.pointer;
sym->attr.target = sym2->attr.target;
}
}
else
{
m = gfc_match (" %e ", &expr1);
if (m != MATCH_YES)
{
std::swap (ns, gfc_current_ns);
gfc_free_namespace (ns);
return m;
}
sym = expr1->symtree->n.sym;
as = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as;
if (expr1->expr_type != EXPR_VARIABLE
|| !(as && as->type == AS_ASSUMED_RANK))
gfc_error_now ("The SELECT RANK selector at %C must be an assumed "
"rank variable");
}
m = gfc_match (" )%t");
if (m != MATCH_YES)
{
gfc_error ("parse error in SELECT RANK statement at %C");
goto cleanup;
}
new_st.op = EXEC_SELECT_RANK;
new_st.expr1 = expr1;
new_st.expr2 = expr2;
new_st.ext.block.ns = gfc_current_ns;
select_type_push (expr1->symtree->n.sym);
gfc_current_ns = ns;
return MATCH_YES;
cleanup:
gfc_free_expr (expr1);
gfc_free_expr (expr2);
gfc_undo_symbols ();
std::swap (ns, gfc_current_ns);
gfc_free_namespace (ns);
return m;
}
/* Match a CASE statement. */
match
@ -6595,6 +6839,107 @@ cleanup:
}
/* Match a RANK statement. */
match
gfc_match_rank_is (void)
{
gfc_case *c = NULL;
match m;
int case_value;
if (gfc_current_state () != COMP_SELECT_RANK)
{
gfc_error ("Unexpected RANK statement at %C");
return MATCH_ERROR;
}
if (gfc_match ("% default") == MATCH_YES)
{
m = match_case_eos ();
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
goto cleanup;
new_st.op = EXEC_SELECT_RANK;
c = gfc_get_case ();
c->ts.type = BT_UNKNOWN;
c->where = gfc_current_locus;
new_st.ext.block.case_list = c;
select_type_stack->tmp = NULL;
return MATCH_YES;
}
if (gfc_match_char ('(') != MATCH_YES)
goto syntax;
c = gfc_get_case ();
c->where = gfc_current_locus;
c->ts = select_type_stack->selector->ts;
m = gfc_match_expr (&c->low);
if (m == MATCH_NO)
{
if (gfc_match_char ('*') == MATCH_YES)
c->low = gfc_get_int_expr (gfc_default_integer_kind,
NULL, -1);
else
goto syntax;
case_value = -1;
}
else if (m == MATCH_YES)
{
/* F2018: R1150 */
if (c->low->expr_type != EXPR_CONSTANT
|| c->low->ts.type != BT_INTEGER
|| c->low->rank)
{
gfc_error ("The SELECT RANK CASE expression at %C must be a "
"scalar, integer constant");
goto cleanup;
}
case_value = (int) mpz_get_si (c->low->value.integer);
/* F2018: C1151 */
if ((case_value < 0) || (case_value > GFC_MAX_DIMENSIONS))
{
gfc_error ("The value of the SELECT RANK CASE expression at "
"%C must not be less than zero or greater than %d",
GFC_MAX_DIMENSIONS);
goto cleanup;
}
}
else
goto cleanup;
if (gfc_match_char (')') != MATCH_YES)
goto syntax;
m = match_case_eos ();
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
goto cleanup;
new_st.op = EXEC_SELECT_RANK;
new_st.ext.block.case_list = c;
/* Create temporary variable. Recycle the select type code. */
select_rank_set_tmp (&c->ts, &case_value);
return MATCH_YES;
syntax:
gfc_error ("Syntax error in RANK specification at %C");
cleanup:
if (c != NULL)
gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */
return MATCH_ERROR;
}
/********************* WHERE subroutines ********************/
/* Match the rest of a simple WHERE statement that follows an IF statement.

2
gcc/fortran/match.h
View File

@ -121,6 +121,8 @@ match gfc_match_select (void);
match gfc_match_select_type (void);
match gfc_match_type_is (void);
match gfc_match_class_is (void);
match gfc_match_select_rank (void);
match gfc_match_rank_is (void);
match gfc_match_where (gfc_statement *);
match gfc_match_elsewhere (void);
match gfc_match_forall (gfc_statement *);

95
gcc/fortran/parse.c
View File

@ -426,6 +426,7 @@ decode_statement (void)
match (NULL, gfc_match_critical, ST_CRITICAL);
match (NULL, gfc_match_select, ST_SELECT_CASE);
match (NULL, gfc_match_select_type, ST_SELECT_TYPE);
match (NULL, gfc_match_select_rank, ST_SELECT_RANK);
/* General statement matching: Instead of testing every possible
statement, we eliminate most possibilities by peeking at the
@ -546,6 +547,7 @@ decode_statement (void)
break;
case 'r':
match ("rank", gfc_match_rank_is, ST_RANK);
match ("read", gfc_match_read, ST_READ);
match ("return", gfc_match_return, ST_RETURN);
match ("rewind", gfc_match_rewind, ST_REWIND);
@ -1537,7 +1539,7 @@ next_statement (void)
#define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
case ST_OMP_PARALLEL: \
case ST_SELECT_RANK: case ST_OMP_PARALLEL: \
case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
@ -2077,12 +2079,18 @@ gfc_ascii_statement (gfc_statement st)
case ST_SELECT_TYPE:
p = "SELECT TYPE";
break;
case ST_SELECT_RANK:
p = "SELECT RANK";
break;
case ST_TYPE_IS:
p = "TYPE IS";
break;
case ST_CLASS_IS:
p = "CLASS IS";
break;
case ST_RANK:
p = "RANK";
break;
case ST_SEQUENCE:
p = "SEQUENCE";
break;
@ -4179,7 +4187,7 @@ parse_select_block (void)
reject_statement ();
}
/* At this point, we're got a nonempty select block. */
/* At this point, we've got a nonempty select block. */
cp = new_level (cp);
*cp = new_st;
@ -4263,7 +4271,7 @@ parse_select_type_block (void)
reject_statement ();
}
/* At this point, we're got a nonempty select block. */
/* At this point, we've got a nonempty select block. */
cp = new_level (cp);
*cp = new_st;
@ -4306,6 +4314,81 @@ done:
}
/* Parse a SELECT RANK construct. */
static void
parse_select_rank_block (void)
{
gfc_statement st;
gfc_code *cp;
gfc_state_data s;
gfc_current_ns = new_st.ext.block.ns;
accept_statement (ST_SELECT_RANK);
cp = gfc_state_stack->tail;
push_state (&s, COMP_SELECT_RANK, gfc_new_block);
/* Make sure that the next statement is a RANK IS or RANK DEFAULT. */
for (;;)
{
st = next_statement ();
if (st == ST_NONE)
unexpected_eof ();
if (st == ST_END_SELECT)
/* Empty SELECT CASE is OK. */
goto done;
if (st == ST_RANK)
break;
gfc_error ("Expected RANK or RANK DEFAULT "
"following SELECT RANK at %C");
reject_statement ();
}
/* At this point, we've got a nonempty select block. */
cp = new_level (cp);
*cp = new_st;
accept_statement (st);
do
{
st = parse_executable (ST_NONE);
switch (st)
{
case ST_NONE:
unexpected_eof ();
case ST_RANK:
cp = new_level (gfc_state_stack->head);
*cp = new_st;
gfc_clear_new_st ();
accept_statement (st);
/* Fall through */
case ST_END_SELECT:
break;
/* Can't have an executable statement because of
parse_executable(). */
default:
unexpected_statement (st);
break;
}
}
while (st != ST_END_SELECT);
done:
pop_state ();
accept_statement (st);
gfc_current_ns = gfc_current_ns->parent;
select_type_pop ();
}
/* Given a symbol, make sure it is not an iteration variable for a DO
statement. This subroutine is called when the symbol is seen in a
context that causes it to become redefined. If the symbol is an
@ -5360,6 +5443,10 @@ parse_executable (gfc_statement st)
parse_select_type_block ();
break;
case ST_SELECT_RANK:
parse_select_rank_block ();
break;
case ST_DO:
parse_do_block ();
if (check_do_closure () == 1)
@ -6410,7 +6497,7 @@ done:
if (flag_dump_fortran_global)
gfc_dump_global_symbols (stdout);
gfc_end_source_files ();
return true;

3
gcc/fortran/parse.h
View File

@ -30,7 +30,8 @@ enum gfc_compile_state
COMP_DERIVED_CONTAINS, COMP_BLOCK, COMP_ASSOCIATE, COMP_IF,
COMP_STRUCTURE, COMP_UNION, COMP_MAP,
COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM,
COMP_SELECT_TYPE, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL, COMP_DO_CONCURRENT
COMP_SELECT_TYPE, COMP_SELECT_RANK, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL,
COMP_DO_CONCURRENT
};
/* Stack element for the current compilation state. These structures

210
gcc/fortran/resolve.c
View File

@ -1866,7 +1866,7 @@ resolve_procedure_expression (gfc_expr* expr)
/* Check that name is not a derived type. */
static bool
is_dt_name (const char *name)
{
@ -5455,13 +5455,16 @@ resolve_variable (gfc_expr *e)
}
}
/* TS 29113, C535b. */
else if ((sym->ts.type == BT_CLASS && sym->attr.class_ok
&& CLASS_DATA (sym)->as
&& CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
|| (sym->ts.type != BT_CLASS && sym->as
&& sym->as->type == AS_ASSUMED_RANK))
else if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
&& CLASS_DATA (sym)->as
&& CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
|| (sym->ts.type != BT_CLASS && sym->as
&& sym->as->type == AS_ASSUMED_RANK))
&& !sym->attr.select_rank_temporary)
{
if (!actual_arg)
if (!actual_arg
&& !(cs_base && cs_base->current
&& cs_base->current->op == EXEC_SELECT_RANK))
{
gfc_error ("Assumed-rank variable %s at %L may only be used as "
"actual argument", sym->name, &e->where);
@ -6915,7 +6918,7 @@ gfc_resolve_expr (gfc_expr *e)
bool t;
bool inquiry_save, actual_arg_save, first_actual_arg_save;
if (e == NULL)
if (e == NULL || e->do_not_resolve_again)
return true;
/* inquiry_argument only applies to variables. */
@ -7025,6 +7028,13 @@ gfc_resolve_expr (gfc_expr *e)
actual_arg = actual_arg_save;
first_actual_arg = first_actual_arg_save;
/* For some reason, resolving these expressions a second time mangles
the typespec of the expression itself. */
if (t && e->expr_type == EXPR_VARIABLE
&& e->symtree->n.sym->attr.select_rank_temporary
&& UNLIMITED_POLY (e->symtree->n.sym))
e->do_not_resolve_again = 1;
return t;
}
@ -8841,7 +8851,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
if (target->ts.type == BT_CLASS)
gfc_fix_class_refs (target);
if (target->rank != 0)
if (target->rank != 0 && !sym->attr.select_rank_temporary)
{
gfc_array_spec *as;
/* The rank may be incorrectly guessed at parsing, therefore make sure
@ -8871,7 +8881,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
CLASS_DATA (sym)->attr.codimension = 1;
}
}
else
else if (!sym->attr.select_rank_temporary)
{
/* target's rank is 0, but the type of the sym is still array valued,
which has to be corrected. */
@ -9490,6 +9500,175 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
}
/* Resolve a SELECT RANK statement. */
static void
resolve_select_rank (gfc_code *code, gfc_namespace *old_ns)
{
gfc_namespace *ns;
gfc_code *body, *new_st, *tail;
gfc_case *c;
char tname[GFC_MAX_SYMBOL_LEN];
char name[2 * GFC_MAX_SYMBOL_LEN];
gfc_symtree *st;
gfc_expr *selector_expr = NULL;
int case_value;
HOST_WIDE_INT charlen = 0;
ns = code->ext.block.ns;
gfc_resolve (ns);
code->op = EXEC_BLOCK;
if (code->expr2)
{
gfc_association_list* assoc;
assoc = gfc_get_association_list ();
assoc->st = code->expr1->symtree;
assoc->target = gfc_copy_expr (code->expr2);
assoc->target->where = code->expr2->where;
/* assoc->variable will be set by resolve_assoc_var. */
code->ext.block.assoc = assoc;
code->expr1->symtree->n.sym->assoc = assoc;
resolve_assoc_var (code->expr1->symtree->n.sym, false);
}
else
code->ext.block.assoc = NULL;
/* Loop over RANK cases. Note that returning on the errors causes a
cascade of further errors because the case blocks do not compile
correctly. */
for (body = code->block; body; body = body->block)
{
c = body->ext.block.case_list;
if (c->low)
case_value = (int) mpz_get_si (c->low->value.integer);
else
case_value = -2;
/* Check for repeated cases. */
for (tail = code->block; tail; tail = tail->block)
{
gfc_case *d = tail->ext.block.case_list;
int case_value2;
if (tail == body)
break;
/* Check F2018: C1153. */
if (!c->low && !d->low)
gfc_error ("RANK DEFAULT at %L is repeated at %L",
&c->where, &d->where);
if (!c->low || !d->low)
continue;
/* Check F2018: C1153. */
case_value2 = (int) mpz_get_si (d->low->value.integer);
if ((case_value == case_value2) && case_value == -1)
gfc_error ("RANK (*) at %L is repeated at %L",
&c->where, &d->where);
else if (case_value == case_value2)
gfc_error ("RANK (%i) at %L is repeated at %L",
case_value, &c->where, &d->where);
}
if (!c->low)
continue;
/* Check F2018: C1155. */
if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable
|| gfc_expr_attr (code->expr1).pointer))
gfc_error ("RANK (*) at %L cannot be used with the pointer or "
"allocatable selector at %L", &c->where, &code->expr1->where);
if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable
|| gfc_expr_attr (code->expr1).pointer))
gfc_error ("RANK (*) at %L cannot be used with the pointer or "
"allocatable selector at %L", &c->where, &code->expr1->where);
}
/* Add EXEC_SELECT to switch on rank. */
new_st = gfc_get_code (code->op);
new_st->expr1 = code->expr1;
new_st->expr2 = code->expr2;
new_st->block = code->block;
code->expr1 = code->expr2 = NULL;
code->block = NULL;
if (!ns->code)
ns->code = new_st;
else
ns->code->next = new_st;
code = new_st;
code->op = EXEC_SELECT_RANK;
selector_expr = code->expr1;
/* Loop over SELECT RANK cases. */
for (body = code->block; body; body = body->block)
{
c = body->ext.block.case_list;
int case_value;
/* Pass on the default case. */
if (c->low == NULL)
continue;
/* Associate temporary to selector. This should only be done
when this case is actually true, so build a new ASSOCIATE
that does precisely this here (instead of using the
'global' one). */
if (c->ts.type == BT_CHARACTER && c->ts.u.cl && c->ts.u.cl->length
&& c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer);
if (c->ts.type == BT_CLASS)
sprintf (tname, "class_%s", c->ts.u.derived->name);
else if (c->ts.type == BT_DERIVED)
sprintf (tname, "type_%s", c->ts.u.derived->name);
else if (c->ts.type != BT_CHARACTER)
sprintf (tname, "%s_%d", gfc_basic_typename (c->ts.type), c->ts.kind);
else
sprintf (tname, "%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
gfc_basic_typename (c->ts.type), charlen, c->ts.kind);
case_value = (int) mpz_get_si (c->low->value.integer);
if (case_value >= 0)
sprintf (name, "__tmp_%s_rank_%d", tname, case_value);
else
sprintf (name, "__tmp_%s_rank_m%d", tname, -case_value);
st = gfc_find_symtree (ns->sym_root, name);
gcc_assert (st->n.sym->assoc);
st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree);
st->n.sym->assoc->target->where = selector_expr->where;
new_st = gfc_get_code (EXEC_BLOCK);
new_st->ext.block.ns = gfc_build_block_ns (ns);
new_st->ext.block.ns->code = body->next;
body->next = new_st;
/* Chain in the new list only if it is marked as dangling. Otherwise
there is a CASE label overlap and this is already used. Just ignore,
the error is diagnosed elsewhere. */
if (st->n.sym->assoc->dangling)
{
new_st->ext.block.assoc = st->n.sym->assoc;
st->n.sym->assoc->dangling = 0;
}
resolve_assoc_var (st->n.sym, false);
}
gfc_current_ns = ns;
gfc_resolve_blocks (code->block, gfc_current_ns);
gfc_current_ns = old_ns;
}
/* Resolve a transfer statement. This is making sure that:
-- a derived type being transferred has only non-pointer components
-- a derived type being transferred doesn't have private components, unless
@ -10366,6 +10545,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
case EXEC_SELECT:
case EXEC_SELECT_TYPE:
case EXEC_SELECT_RANK:
case EXEC_FORALL:
case EXEC_DO:
case EXEC_DO_WHILE:
@ -11643,6 +11823,10 @@ start:
resolve_select_type (code, ns);
break;
case EXEC_SELECT_RANK:
resolve_select_rank (code, ns);
break;
case EXEC_BLOCK:
resolve_block_construct (code);
break;
@ -13573,7 +13757,7 @@ resolve_typebound_procedure (gfc_symtree* stree)
}
else
{
/* If proc has not been resolved at this point, proc->name may
/* If proc has not been resolved at this point, proc->name may
actually be a USE associated entity. See PR fortran/89647. */
if (!proc->resolved
&& proc->attr.function == 0 && proc->attr.subroutine == 0)
@ -15048,7 +15232,9 @@ resolve_symbol (gfc_symbol *sym)
}
/* TS 29113, C535a. */
if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy
&& !sym->attr.select_type_temporary)
&& !sym->attr.select_type_temporary
&& !(cs_base && cs_base->current
&& cs_base->current->op == EXEC_SELECT_RANK))
{
gfc_error ("Assumed-rank array at %L must be a dummy argument",
&sym->declared_at);

1
gcc/fortran/st.c
View File

@ -141,6 +141,7 @@ gfc_free_statement (gfc_code *p)
case EXEC_SELECT:
case EXEC_SELECT_TYPE:
case EXEC_SELECT_RANK:
if (p->ext.block.case_list)
gfc_free_case_list (p->ext.block.case_list);
break;

8
gcc/fortran/trans-array.c
View File

@ -3609,7 +3609,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
if (ar->dimen == 0)
{
gcc_assert (ar->codimen);
gcc_assert (ar->codimen || sym->attr.select_rank_temporary);
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
@ -7758,6 +7758,12 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
gfc_conv_descriptor_offset_set (&loop.pre, parm,
gfc_conv_descriptor_offset_get (desc));
}
else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
&& !se->data_not_needed
&& gfc_expr_attr (expr).select_rank_temporary)
{
gfc_conv_descriptor_offset_set (&loop.pre, parm, gfc_index_zero_node);
}
else if (onebased && (!rank_remap || se->use_offset)
&& expr->symtree
&& !(expr->symtree->n.sym && expr->symtree->n.sym->ts.type == BT_CLASS

315
gcc/fortran/trans-stmt.c
View File

@ -1641,6 +1641,48 @@ class_has_len_component (gfc_symbol *sym)
}
static void
copy_descriptor (stmtblock_t *block, tree dst, tree src, int rank)
{
int n;
tree dim;
tree tmp;
tree tmp2;
tree size;
tree offset;
offset = gfc_index_zero_node;
/* Use memcpy to copy the descriptor. The size is the minimum of
the sizes of 'src' and 'dst'. This avoids a non-trivial conversion. */
tmp = TYPE_SIZE_UNIT (TREE_TYPE (src));
tmp2 = TYPE_SIZE_UNIT (TREE_TYPE (dst));
size = fold_build2_loc (input_location, MIN_EXPR,
TREE_TYPE (tmp), tmp, tmp2);
tmp = builtin_decl_explicit (BUILT_IN_MEMCPY);
tmp = build_call_expr_loc (input_location, tmp, 3,
gfc_build_addr_expr (NULL_TREE, dst),
gfc_build_addr_expr (NULL_TREE, src),
fold_convert (size_type_node, size));
gfc_add_expr_to_block (block, tmp);
/* Set the offset correctly. */
for (n = 0; n < rank; n++)
{
dim = gfc_rank_cst[n];
tmp = gfc_conv_descriptor_lbound_get (src, dim);
tmp2 = gfc_conv_descriptor_stride_get (src, dim);
tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
tmp, tmp2);
offset = fold_build2_loc (input_location, MINUS_EXPR,
TREE_TYPE (offset), offset, tmp);
offset = gfc_evaluate_now (offset, block);
}
gfc_conv_descriptor_offset_set (block, dst, offset);
}
/* Do proper initialization for ASSOCIATE names. */
static void
@ -1658,6 +1700,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
bool need_len_assign;
bool whole_array = true;
gfc_ref *ref;
gfc_symbol *sym2;
gcc_assert (sym->assoc);
e = sym->assoc->target;
@ -1690,12 +1733,140 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
&& e->ts.u.derived->attr.unlimited_polymorphic))
&& (sym->ts.type == BT_CHARACTER
|| ((sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED)
&& class_has_len_component (sym))));
&& class_has_len_component (sym)))
&& !sym->attr.select_rank_temporary);
/* Do a `pointer assignment' with updated descriptor (or assign descriptor
to array temporary) for arrays with either unknown shape or if associating
to a variable. */
if (sym->attr.dimension && !class_target
&& (sym->as->type == AS_DEFERRED || sym->assoc->variable))
to a variable. Select rank temporaries need somewhat different treatment
to other associate names and case temporaries. This because the selector
is assumed rank and so the offset in particular has to be changed. Also,
the case temporaries carry both allocatable and target attributes if
present in the selector. This means that an allocatation or change of
association can occur and so has to be dealt with. */
if (sym->attr.select_rank_temporary)
{
gfc_se se;
tree class_decl = NULL_TREE;
int rank = 0;
bool class_ptr;
sym2 = e->symtree->n.sym;
gfc_init_se (&se, NULL);
if (e->ts.type == BT_CLASS)
{
/* Go straight to the class data. */
if (sym2->attr.dummy)
{
class_decl = DECL_LANG_SPECIFIC (sym2->backend_decl) ?
GFC_DECL_SAVED_DESCRIPTOR (sym2->backend_decl) :
sym2->backend_decl;
if (POINTER_TYPE_P (TREE_TYPE (class_decl)))
class_decl = build_fold_indirect_ref_loc (input_location,
class_decl);
gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (class_decl)));
se.expr = gfc_class_data_get (class_decl);
}
else
{
class_decl = sym2->backend_decl;
gfc_conv_expr_descriptor (&se, e);
if (POINTER_TYPE_P (TREE_TYPE (se.expr)))
se.expr = build_fold_indirect_ref_loc (input_location,
se.expr);
}
if (CLASS_DATA (sym)->as && CLASS_DATA (sym)->as->rank > 0)
rank = CLASS_DATA (sym)->as->rank;
}
else
{
gfc_conv_expr_descriptor (&se, e);
if (sym->as && sym->as->rank > 0)
rank = sym->as->rank;
}
desc = sym->backend_decl;
/* The SELECT TYPE mechanisms turn class temporaries into pointers, which
point to the selector. */
class_ptr = class_decl != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (desc));
if (class_ptr)
{
tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (desc)), "class");
tmp = gfc_build_addr_expr (NULL, tmp);
gfc_add_modify (&se.pre, desc, tmp);
tmp = gfc_class_vptr_get (class_decl);
gfc_add_modify (&se.pre, gfc_class_vptr_get (desc), tmp);
if (UNLIMITED_POLY (sym))
gfc_add_modify (&se.pre, gfc_class_len_get (desc),
gfc_class_len_get (class_decl));
desc = gfc_class_data_get (desc);
}
/* SELECT RANK temporaries can carry the allocatable and pointer
attributes so the selector descriptor must be copied in and
copied out. */
if (rank > 0)
copy_descriptor (&se.pre, desc, se.expr, rank);
else
{
tmp = gfc_conv_descriptor_data_get (se.expr);
gfc_add_modify (&se.pre, desc,
fold_convert (TREE_TYPE (desc), tmp));
}
/* Deal with associate_name => selector. Class associate names are
treated in the same way as in SELECT TYPE. */
sym2 = sym->assoc->target->symtree->n.sym;
if (sym2->assoc && sym->assoc->target && sym2->ts.type != BT_CLASS)
{
sym2 = sym2->assoc->target->symtree->n.sym;
se.expr = sym2->backend_decl;
if (POINTER_TYPE_P (TREE_TYPE (se.expr)))
se.expr = build_fold_indirect_ref_loc (input_location,
se.expr);
}
/* There could have been reallocation. Copy descriptor back to the
selector and update the offset. */
if (sym->attr.allocatable || sym->attr.pointer
|| (sym->ts.type == BT_CLASS
&& (CLASS_DATA (sym)->attr.allocatable
|| CLASS_DATA (sym)->attr.pointer)))
{
if (rank > 0)
copy_descriptor (&se.post, se.expr, desc, rank);
else
{
tmp = gfc_conv_descriptor_data_get (desc);
gfc_conv_descriptor_data_set (&se.post, se.expr, tmp);
}
/* The dynamic type could have changed too. */
if (sym->ts.type == BT_CLASS)
{
tmp = sym->backend_decl;
if (class_ptr)
tmp = build_fold_indirect_ref_loc (input_location, tmp);
gfc_add_modify (&se.post, gfc_class_vptr_get (class_decl),
gfc_class_vptr_get (tmp));
if (UNLIMITED_POLY (sym))
gfc_add_modify (&se.post, gfc_class_len_get (class_decl),
gfc_class_len_get (tmp));
}
}
tmp = gfc_finish_block (&se.post);
gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), tmp);
}
/* Now all the other kinds of associate variable. */
else if (sym->attr.dimension && !class_target
&& (sym->as->type == AS_DEFERRED || sym->assoc->variable))
{
gfc_se se;
tree desc;
@ -3424,6 +3595,142 @@ gfc_trans_select_type (gfc_code * code)
}
static tree
gfc_trans_select_rank_cases (gfc_code * code)
{
gfc_code *c;
gfc_case *cp;
tree tmp;
tree cond;
tree low;
tree sexpr;
tree rank;
tree rank_minus_one;
tree minus_one;
gfc_se se;
gfc_se cse;
stmtblock_t block;
stmtblock_t body;
bool def = false;
gfc_start_block (&block);
/* Calculate the switch expression. */
gfc_init_se (&se, NULL);
gfc_conv_expr_descriptor (&se, code->expr1);
rank = gfc_conv_descriptor_rank (se.expr);
rank = gfc_evaluate_now (rank, &block);
minus_one = build_int_cst (TREE_TYPE (rank), -1);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
fold_convert (gfc_array_index_type, rank),
build_int_cst (gfc_array_index_type, 1));
rank_minus_one = gfc_evaluate_now (tmp, &block);
tmp = gfc_conv_descriptor_ubound_get (se.expr, rank_minus_one);
cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
tmp, build_int_cst (TREE_TYPE (tmp), -1));
tmp = fold_build3_loc (input_location, COND_EXPR,
TREE_TYPE (rank), cond,
rank, minus_one);
cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
rank, build_int_cst (TREE_TYPE (rank), 0));
sexpr = fold_build3_loc (input_location, COND_EXPR,
TREE_TYPE (rank), cond,
rank, tmp);
sexpr = gfc_evaluate_now (sexpr, &block);
TREE_USED (code->exit_label) = 0;
repeat:
for (c = code->block; c; c = c->block)
{
cp = c->ext.block.case_list;
/* Assume it's the default case. */
low = NULL_TREE;
tmp = NULL_TREE;
/* Put the default case at the end. */
if ((!def && !cp->low) || (def && cp->low))
continue;
if (cp->low)
{
gfc_init_se (&cse, NULL);
gfc_conv_expr_val (&cse, cp->low);
gfc_add_block_to_block (&block, &cse.pre);
low = cse.expr;
}
gfc_init_block (&body);
/* Add the statements for this case. */
tmp = gfc_trans_code (c->next);
gfc_add_expr_to_block (&body, tmp);
/* Break to the end of the SELECT RANK construct. The default
case just falls through. */
if (!def)
{
TREE_USED (code->exit_label) = 1;
tmp = build1_v (GOTO_EXPR, code->exit_label);
gfc_add_expr_to_block (&body, tmp);
}
tmp = gfc_finish_block (&body);
if (low != NULL_TREE)
{
cond = fold_build2_loc (input_location, EQ_EXPR,
TREE_TYPE (sexpr), sexpr,
fold_convert (TREE_TYPE (sexpr), low));
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
cond, tmp,
build_empty_stmt (input_location));
}
gfc_add_expr_to_block (&block, tmp);
}
if (!def)
{
def = true;
goto repeat;
}
return gfc_finish_block (&block);
}
tree
gfc_trans_select_rank (gfc_code * code)
{
stmtblock_t block;
tree body;
tree exit_label;
gcc_assert (code && code->expr1);
gfc_init_block (&block);
/* Build the exit label and hang it in. */
exit_label = gfc_build_label_decl (NULL_TREE);
code->exit_label = exit_label;
/* Empty SELECT constructs are legal. */
if (code->block == NULL)
body = build_empty_stmt (input_location);
else
body = gfc_trans_select_rank_cases (code);
/* Build everything together. */
gfc_add_expr_to_block (&block, body);
if (TREE_USED (exit_label))
gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label));
return gfc_finish_block (&block);
}
/* Traversal function to substitute a replacement symtree if the symbol
in the expression is the same as that passed. f == 2 signals that
that variable itself is not to be checked - only the references.

1
gcc/fortran/trans-stmt.h
View File

@ -53,6 +53,7 @@ tree gfc_trans_do_concurrent (gfc_code *);
tree gfc_trans_do_while (gfc_code *);
tree gfc_trans_select (gfc_code *);
tree gfc_trans_select_type (gfc_code *);
tree gfc_trans_select_rank (gfc_code *);
tree gfc_trans_sync (gfc_code *, gfc_exec_op);
tree gfc_trans_lock_unlock (gfc_code *, gfc_exec_op);
tree gfc_trans_event_post_wait (gfc_code *, gfc_exec_op);

4
gcc/fortran/trans.c
View File

@ -1968,6 +1968,10 @@ trans_code (gfc_code * code, tree cond)
res = gfc_trans_select_type (code);
break;
case EXEC_SELECT_RANK:
res = gfc_trans_select_rank (code);
break;
case EXEC_FLUSH:
res = gfc_trans_flush (code);
break;

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
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

179
gcc/testsuite/gfortran.dg/select_rank_1.f90 Normal file
View File

@ -0,0 +1,179 @@
! { 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

85
gcc/testsuite/gfortran.dg/select_rank_2.f90 Normal file
View File

@ -0,0 +1,85 @@
! { 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