aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/match.cc
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran/match.cc')
-rw-r--r--gcc/fortran/match.cc124
1 files changed, 112 insertions, 12 deletions
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index 474ba81..e009c82 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -2608,7 +2608,66 @@ cleanup:
}
-/* Match the header of a FORALL statement. */
+/* Apply type-spec to iterator and create shadow variable if needed. */
+
+static void
+apply_typespec_to_iterator (gfc_forall_iterator *iter, gfc_typespec *ts,
+ locus *loc)
+{
+ char *name;
+ gfc_expr *v;
+ gfc_symtree *st;
+
+ /* When a type-spec is provided in DO CONCURRENT/FORALL, F2018 19.4(6)
+ requires the index-name to have scope limited to the construct,
+ shadowing any variable with the same name from outer scope.
+ If the index-name was not previously declared, we can simply set its
+ type. Otherwise, create a shadow variable with "_" prefix. */
+ iter->shadow = false;
+ v = iter->var;
+ if (v->ts.type == BT_UNKNOWN)
+ {
+ /* Variable not declared in outer scope - just set the type. */
+ v->ts.type = v->symtree->n.sym->ts.type = BT_INTEGER;
+ v->ts.kind = v->symtree->n.sym->ts.kind = ts->kind;
+ gfc_set_sym_referenced (v->symtree->n.sym);
+ }
+ else
+ {
+ /* Variable exists in outer scope - must create shadow to comply
+ with F2018 19.4(6) scoping rules. */
+ name = (char *) alloca (strlen (v->symtree->name) + 2);
+ strcpy (name, "_");
+ strcat (name, v->symtree->name);
+ if (gfc_get_sym_tree (name, NULL, &st, false) != 0)
+ gfc_internal_error ("Failed to create shadow variable symtree for "
+ "DO CONCURRENT type-spec at %L", loc);
+
+ v = gfc_get_expr ();
+ v->where = gfc_current_locus;
+ v->expr_type = EXPR_VARIABLE;
+ v->ts.type = st->n.sym->ts.type = ts->type;
+ v->ts.kind = st->n.sym->ts.kind = ts->kind;
+ st->n.sym->forall_index = true;
+ v->symtree = st;
+ gfc_replace_expr (iter->var, v);
+ iter->shadow = true;
+ gfc_set_sym_referenced (st->n.sym);
+ }
+
+ /* Convert iterator bounds to the specified type. */
+ gfc_convert_type (iter->start, ts, 1);
+ gfc_convert_type (iter->end, ts, 1);
+ gfc_convert_type (iter->stride, ts, 1);
+}
+
+
+/* Match the header of a FORALL statement. In F2008 and F2018, the form of
+ the header is:
+
+ ([ type-spec :: ] concurrent-control-list [, scalar-mask-expr ] )
+
+ where type-spec is INTEGER. */
static match
match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
@@ -2616,6 +2675,9 @@ match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
gfc_forall_iterator *head, *tail, *new_iter;
gfc_expr *msk;
match m;
+ gfc_typespec ts;
+ bool seen_ts = false;
+ locus loc;
gfc_gobble_whitespace ();
@@ -2625,12 +2687,40 @@ match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
if (gfc_match_char ('(') != MATCH_YES)
return MATCH_NO;
+ /* Check for an optional type-spec. */
+ gfc_clear_ts (&ts);
+ loc = gfc_current_locus;
+ m = gfc_match_type_spec (&ts);
+ if (m == MATCH_YES)
+ {
+ seen_ts = (gfc_match (" ::") == MATCH_YES);
+
+ if (seen_ts)
+ {
+ if (!gfc_notify_std (GFC_STD_F2008, "FORALL or DO CONCURRENT "
+ "construct includes type specification "
+ "at %L", &loc))
+ goto cleanup;
+
+ if (ts.type != BT_INTEGER)
+ {
+ gfc_error ("Type-spec at %L must be an INTEGER type", &loc);
+ goto cleanup;
+ }
+ }
+ }
+ else if (m == MATCH_ERROR)
+ goto syntax;
+
m = match_forall_iterator (&new_iter);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
goto syntax;
+ if (seen_ts)
+ apply_typespec_to_iterator (new_iter, &ts, &loc);
+
head = tail = new_iter;
for (;;)
@@ -2644,6 +2734,9 @@ match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
if (m == MATCH_YES)
{
+ if (seen_ts)
+ apply_typespec_to_iterator (new_iter, &ts, &loc);
+
tail->next = new_iter;
tail = new_iter;
continue;
@@ -2892,7 +2985,7 @@ gfc_match_do (void)
locus where = gfc_current_locus;
if (gfc_match_eos () == MATCH_YES)
- break;
+ goto concurr_ok;
else if (gfc_match ("local ( ") == MATCH_YES)
{
@@ -3141,6 +3234,7 @@ gfc_match_do (void)
if (gfc_match_eos () != MATCH_YES)
goto concurr_cleanup;
+concurr_ok:
if (label != NULL
&& !gfc_reference_st_label (label, ST_LABEL_DO_TARGET))
goto concurr_cleanup;
@@ -5292,7 +5386,7 @@ match
gfc_match_nullify (void)
{
gfc_code *tail;
- gfc_expr *e, *p;
+ gfc_expr *e, *p = NULL;
match m;
tail = NULL;
@@ -7170,9 +7264,11 @@ select_type_push (gfc_symbol *sel)
/* Set the temporary for the current intrinsic SELECT TYPE selector. */
static gfc_symtree *
-select_intrinsic_set_tmp (gfc_typespec *ts)
+select_intrinsic_set_tmp (gfc_typespec *ts, const char *var_name)
{
- char name[GFC_MAX_SYMBOL_LEN];
+ /* Keep size in sync with the buffer size in resolve_select_type as it
+ determines the final name through truncation. */
+ char name[GFC_MAX_SYMBOL_LEN + 12 + 1];
gfc_symtree *tmp;
HOST_WIDE_INT charlen = 0;
gfc_symbol *selector = select_type_stack->selector;
@@ -7191,12 +7287,12 @@ select_intrinsic_set_tmp (gfc_typespec *ts)
charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
if (ts->type != BT_CHARACTER)
- sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type),
- ts->kind);
+ snprintf (name, sizeof (name), "__tmp_%s_%d_%s",
+ gfc_basic_typename (ts->type), ts->kind, var_name);
else
snprintf (name, sizeof (name),
- "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
- gfc_basic_typename (ts->type), charlen, ts->kind);
+ "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d_%s",
+ gfc_basic_typename (ts->type), charlen, ts->kind, var_name);
gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
sym = tmp->n.sym;
@@ -7238,7 +7334,9 @@ select_type_set_tmp (gfc_typespec *ts)
return;
}
- tmp = select_intrinsic_set_tmp (ts);
+ gfc_expr *select_type_expr = gfc_state_stack->construct->expr1;
+ const char *var_name = gfc_var_name_for_select_type_temp (select_type_expr);
+ tmp = select_intrinsic_set_tmp (ts, var_name);
if (tmp == NULL)
{
@@ -7246,9 +7344,11 @@ select_type_set_tmp (gfc_typespec *ts)
return;
if (ts->type == BT_CLASS)
- sprintf (name, "__tmp_class_%s", ts->u.derived->name);
+ snprintf (name, sizeof (name), "__tmp_class_%s_%s", ts->u.derived->name,
+ var_name);
else
- sprintf (name, "__tmp_type_%s", ts->u.derived->name);
+ snprintf (name, sizeof (name), "__tmp_type_%s_%s", ts->u.derived->name,
+ var_name);
gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
sym = tmp->n.sym;
generated by cgit v1.1 at 2026-01-08 05:15:03 +0000