diff options
Diffstat (limited to 'gcc/fortran/match.cc')
-rw-r--r-- | gcc/fortran/match.cc | 434 |
1 files changed, 375 insertions, 59 deletions
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc index ec9e587..8355a39 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -1814,12 +1814,53 @@ gfc_free_iterator (gfc_iterator *iter, int flag) free (iter); } +static match +match_named_arg (const char *pat, const char *name, gfc_expr **e, + gfc_statement st_code) +{ + match m; + gfc_expr *tmp; + + m = gfc_match (pat, &tmp); + if (m == MATCH_ERROR) + { + gfc_syntax_error (st_code); + return m; + } + if (m == MATCH_YES) + { + if (*e) + { + gfc_error ("Duplicate %s attribute in %C", name); + gfc_free_expr (tmp); + return MATCH_ERROR; + } + *e = tmp; + + return MATCH_YES; + } + return MATCH_NO; +} + +static match +match_stat_errmsg (struct sync_stat *sync_stat, gfc_statement st_code) +{ + match m; + + m = match_named_arg (" stat = %v", "STAT", &sync_stat->stat, st_code); + if (m != MATCH_NO) + return m; + + m = match_named_arg (" errmsg = %v", "ERRMSG", &sync_stat->errmsg, st_code); + return m; +} /* Match a CRITICAL statement. */ match gfc_match_critical (void) { gfc_st_label *label = NULL; + match m; if (gfc_match_label () == MATCH_ERROR) return MATCH_ERROR; @@ -1830,12 +1871,29 @@ gfc_match_critical (void) if (gfc_match_st_label (&label) == MATCH_ERROR) return MATCH_ERROR; - if (gfc_match_eos () != MATCH_YES) + if (gfc_match_eos () == MATCH_YES) + goto done; + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + for (;;) { - gfc_syntax_error (ST_CRITICAL); - return MATCH_ERROR; + m = match_stat_errmsg (&new_st.ext.sync_stat, ST_CRITICAL); + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (',') == MATCH_YES) + continue; + + break; } + if (gfc_match (" )%t") != MATCH_YES) + goto syntax; + +done: + if (gfc_pure (NULL)) { gfc_error ("Image control statement CRITICAL at %C in PURE procedure"); @@ -1856,9 +1914,9 @@ gfc_match_critical (void) if (flag_coarray == GFC_FCOARRAY_NONE) { - gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to " - "enable"); - return MATCH_ERROR; + gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to " + "enable"); + return MATCH_ERROR; } if (gfc_find_state (COMP_CRITICAL)) @@ -1869,13 +1927,21 @@ gfc_match_critical (void) new_st.op = EXEC_CRITICAL; - if (label != NULL - && !gfc_reference_st_label (label, ST_LABEL_TARGET)) - return MATCH_ERROR; + if (label != NULL && !gfc_reference_st_label (label, ST_LABEL_TARGET)) + goto cleanup; return MATCH_YES; -} +syntax: + gfc_syntax_error (ST_CRITICAL); + +cleanup: + gfc_free_expr (new_st.ext.sync_stat.stat); + gfc_free_expr (new_st.ext.sync_stat.errmsg); + new_st.ext.sync_stat = {NULL, NULL}; + + return MATCH_ERROR; +} /* Match a BLOCK statement. */ @@ -1900,29 +1966,29 @@ gfc_match_block (void) return MATCH_YES; } - -/* Match an ASSOCIATE statement. */ - -match -gfc_match_associate (void) +bool +check_coarray_assoc (const char *name, gfc_association_list *assoc) { - if (gfc_match_label () == MATCH_ERROR) - return MATCH_ERROR; - - if (gfc_match (" associate") != MATCH_YES) - return MATCH_NO; - - /* Match the association list. */ - if (gfc_match_char ('(') != MATCH_YES) + if (assoc->target->expr_type == EXPR_VARIABLE + && !strcmp (assoc->target->symtree->name, name)) { - gfc_error ("Expected association list at %C"); - return MATCH_ERROR; + gfc_error ("Codimension decl name %qs in association at %L " + "must not be the same as a selector", + name, &assoc->where); + return false; } + return true; +} + +match +match_association_list (bool for_change_team = false) +{ new_st.ext.block.assoc = NULL; while (true) { - gfc_association_list* newAssoc = gfc_get_association_list (); - gfc_association_list* a; + gfc_association_list *newAssoc = gfc_get_association_list (); + gfc_association_list *a; + locus pre_name = gfc_current_locus; /* Match the next association. */ if (gfc_match (" %n ", newAssoc->name) != MATCH_YES) @@ -1932,7 +1998,7 @@ gfc_match_associate (void) } /* Required for an assumed rank target. */ - if (gfc_peek_char () == '(') + if (!for_change_team && gfc_peek_char () == '(') { newAssoc->ar = gfc_get_array_ref (); if (gfc_match_array_ref (newAssoc->ar, NULL, 0, 0) != MATCH_YES) @@ -1946,26 +2012,53 @@ gfc_match_associate (void) gfc_error_now ("The bounds remapping list at %C is an experimental " "F202y feature. Use std=f202y to enable"); + if (for_change_team && gfc_peek_char () == '[') + { + if (!newAssoc->ar) + newAssoc->ar = gfc_get_array_ref (); + if (gfc_match_array_spec (&newAssoc->ar->as, false, true) + == MATCH_ERROR) + goto assocListError; + } + /* Match the next association. */ if (gfc_match (" =>", newAssoc->name) != MATCH_YES) { - gfc_error ("Expected association at %C"); - goto assocListError; + if (for_change_team) + gfc_current_locus = pre_name; + + free (newAssoc); + return MATCH_NO; } - if (gfc_match (" %e", &newAssoc->target) != MATCH_YES) + if (!for_change_team) { - /* Have another go, allowing for procedure pointer selectors. */ - gfc_matching_procptr_assignment = 1; if (gfc_match (" %e", &newAssoc->target) != MATCH_YES) { + /* Have another go, allowing for procedure pointer selectors. */ + gfc_matching_procptr_assignment = 1; + if (gfc_match (" %e", &newAssoc->target) != MATCH_YES) + { + gfc_matching_procptr_assignment = 0; + gfc_error ("Invalid association target at %C"); + goto assocListError; + } gfc_matching_procptr_assignment = 0; - gfc_error ("Invalid association target at %C"); + } + newAssoc->where = gfc_current_locus; + } + else + { + newAssoc->where = gfc_current_locus; + /* F2018, C1116: A selector in a coarray-association shall be a named + coarray. */ + if (gfc_match (" %v", &newAssoc->target) != MATCH_YES) + { + gfc_error ("Selector in coarray association as %C shall be a " + "named coarray"); goto assocListError; } - gfc_matching_procptr_assignment = 0; } - newAssoc->where = gfc_current_locus; /* Check that the current name is not yet in the list. */ for (a = new_st.ext.block.assoc; a; a = a->next) @@ -1976,6 +2069,35 @@ gfc_match_associate (void) goto assocListError; } + if (for_change_team) + { + /* F2018, C1113: In a change-team-stmt, a coarray-name in a + codimension-decl shall not be the same as a selector, or another + coarray-name, in that statement. + The latter is already checked for above. So check only the + former. + */ + if (!check_coarray_assoc (newAssoc->name, newAssoc)) + goto assocListError; + + for (a = new_st.ext.block.assoc; a; a = a->next) + { + if (!check_coarray_assoc (newAssoc->name, a) + || !check_coarray_assoc (a->name, newAssoc)) + goto assocListError; + + /* F2018, C1115: No selector shall appear more than once in a + * given change-team-stmt. */ + if (!strcmp (newAssoc->target->symtree->name, + a->target->symtree->name)) + { + gfc_error ("Selector at %L duplicates selector at %L", + &newAssoc->target->where, &a->target->where); + goto assocListError; + } + } + } + /* The target expression must not be coindexed. */ if (gfc_is_coindexed (newAssoc->target)) { @@ -2042,8 +2164,40 @@ gfc_match_associate (void) assocListError: free (newAssoc); + return MATCH_ERROR; + } + + return MATCH_YES; +} + +/* Match an ASSOCIATE statement. */ + +match +gfc_match_associate (void) +{ + match m; + if (gfc_match_label () == MATCH_ERROR) + return MATCH_ERROR; + + if (gfc_match (" associate") != MATCH_YES) + return MATCH_NO; + + /* Match the association list. */ + if (gfc_match_char ('(') != MATCH_YES) + { + gfc_error ("Expected association list at %C"); + return MATCH_ERROR; + } + + m = match_association_list (); + if (m == MATCH_ERROR) + goto error; + else if (m == MATCH_NO) + { + gfc_error ("Expected association at %C"); goto error; } + if (gfc_match_char (')') != MATCH_YES) { /* This should never happen as we peek above. */ @@ -2738,7 +2892,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) { @@ -2987,6 +3141,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; @@ -3171,6 +3326,7 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op) case COMP_ASSOCIATE: case COMP_BLOCK: + case COMP_CHANGE_TEAM: case COMP_IF: case COMP_SELECT: case COMP_SELECT_TYPE: @@ -3848,7 +4004,9 @@ match gfc_match_form_team (void) { match m; - gfc_expr *teamid,*team; + gfc_expr *teamid, *team, *new_index; + + teamid = team = new_index = NULL; if (!gfc_notify_std (GFC_STD_F2018, "FORM TEAM statement at %C")) return MATCH_ERROR; @@ -3866,18 +4024,61 @@ gfc_match_form_team (void) if (gfc_match ("%e", &team) != MATCH_YES) goto syntax; - m = gfc_match_char (')'); + m = gfc_match_char (','); + if (m == MATCH_ERROR) + goto syntax; if (m == MATCH_NO) + { + m = gfc_match_char (')'); + if (m == MATCH_YES) + goto done; + goto syntax; + } + + for (;;) + { + m = match_stat_errmsg (&new_st.ext.sync_stat, ST_FORM_TEAM); + if (m == MATCH_ERROR) + goto cleanup; + + m = match_named_arg (" new_index = %e", "NEW_INDEX", &new_index, + ST_FORM_TEAM); + if (m == MATCH_ERROR) + goto cleanup; + + m = gfc_match_char (','); + if (m == MATCH_YES) + continue; + + break; + } + + if (m == MATCH_ERROR) + goto syntax; + + if (gfc_match (" )%t") != MATCH_YES) goto syntax; +done: + new_st.expr1 = teamid; new_st.expr2 = team; + new_st.expr3 = new_index; return MATCH_YES; syntax: gfc_syntax_error (ST_FORM_TEAM); +cleanup: + gfc_free_expr (new_index); + gfc_free_expr (new_st.ext.sync_stat.stat); + gfc_free_expr (new_st.ext.sync_stat.errmsg); + new_st.ext.sync_stat = {NULL, NULL}; + + gfc_free_expr (team); + gfc_free_expr (teamid); + return MATCH_ERROR; } @@ -3887,7 +4088,13 @@ match gfc_match_change_team (void) { match m; - gfc_expr *team; + gfc_expr *team = NULL; + + if (gfc_match_label () == MATCH_ERROR) + return MATCH_ERROR; + + if (gfc_match (" change% team") != MATCH_YES) + return MATCH_NO; if (!gfc_notify_std (GFC_STD_F2018, "CHANGE TEAM statement at %C")) return MATCH_ERROR; @@ -3895,15 +4102,41 @@ gfc_match_change_team (void) if (gfc_match_char ('(') == MATCH_NO) goto syntax; - new_st.op = EXEC_CHANGE_TEAM; - if (gfc_match ("%e", &team) != MATCH_YES) goto syntax; - m = gfc_match_char (')'); + m = gfc_match_char (','); + if (m == MATCH_ERROR) + goto syntax; if (m == MATCH_NO) + { + m = gfc_match_char (')'); + if (m == MATCH_YES) + goto done; + goto syntax; + } + + m = match_association_list (true); + if (m == MATCH_ERROR) + goto cleanup; + else if (m == MATCH_NO) + for (;;) + { + m = match_stat_errmsg (&new_st.ext.block.sync_stat, ST_CHANGE_TEAM); + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (',') == MATCH_YES) + continue; + + break; + } + + if (gfc_match (" )%t") != MATCH_YES) goto syntax; +done: + new_st.expr1 = team; return MATCH_YES; @@ -3911,20 +4144,49 @@ gfc_match_change_team (void) syntax: gfc_syntax_error (ST_CHANGE_TEAM); +cleanup: + gfc_free_expr (new_st.ext.block.sync_stat.stat); + gfc_free_expr (new_st.ext.block.sync_stat.errmsg); + new_st.ext.block.sync_stat = {NULL, NULL}; + gfc_free_association_list (new_st.ext.block.assoc); + new_st.ext.block.assoc = NULL; + gfc_free_expr (team); + return MATCH_ERROR; } -/* Match a END TEAM statement. */ +/* Match an END TEAM statement. */ match gfc_match_end_team (void) { - if (!gfc_notify_std (GFC_STD_F2018, "END TEAM statement at %C")) - return MATCH_ERROR; + if (gfc_match_eos () == MATCH_YES) + goto done; - if (gfc_match_char ('(') == MATCH_YES) + if (gfc_match_char ('(') != MATCH_YES) + { + /* There could be a team-construct-name following. Let caller decide + about error. */ + new_st.op = EXEC_END_TEAM; + return MATCH_NO; + } + + for (;;) + { + if (match_stat_errmsg (&new_st.ext.sync_stat, ST_END_TEAM) == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (',') == MATCH_YES) + continue; + + break; + } + + if (gfc_match_char (')') != MATCH_YES) goto syntax; +done: + new_st.op = EXEC_END_TEAM; return MATCH_YES; @@ -3932,6 +4194,14 @@ gfc_match_end_team (void) syntax: gfc_syntax_error (ST_END_TEAM); +cleanup: + gfc_free_expr (new_st.ext.sync_stat.stat); + gfc_free_expr (new_st.ext.sync_stat.errmsg); + new_st.ext.sync_stat = {NULL, NULL}; + + /* Try to match the closing bracket to allow error recovery. */ + gfc_match_char (')'); + return MATCH_ERROR; } @@ -3941,7 +4211,7 @@ match gfc_match_sync_team (void) { match m; - gfc_expr *team; + gfc_expr *team = NULL; if (!gfc_notify_std (GFC_STD_F2018, "SYNC TEAM statement at %C")) return MATCH_ERROR; @@ -3954,10 +4224,34 @@ gfc_match_sync_team (void) if (gfc_match ("%e", &team) != MATCH_YES) goto syntax; - m = gfc_match_char (')'); + m = gfc_match_char (','); + if (m == MATCH_ERROR) + goto syntax; if (m == MATCH_NO) + { + m = gfc_match_char (')'); + if (m == MATCH_YES) + goto done; + goto syntax; + } + + for (;;) + { + m = match_stat_errmsg (&new_st.ext.sync_stat, ST_SYNC_TEAM); + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char (',') == MATCH_YES) + continue; + + break; + } + + if (gfc_match (" )%t") != MATCH_YES) goto syntax; +done: + new_st.expr1 = team; return MATCH_YES; @@ -3965,6 +4259,13 @@ gfc_match_sync_team (void) syntax: gfc_syntax_error (ST_SYNC_TEAM); +cleanup: + gfc_free_expr (new_st.ext.sync_stat.stat); + gfc_free_expr (new_st.ext.sync_stat.errmsg); + new_st.ext.sync_stat = {NULL, NULL}; + + gfc_free_expr (team); + return MATCH_ERROR; } @@ -4992,7 +5293,7 @@ match gfc_match_nullify (void) { gfc_code *tail; - gfc_expr *e, *p; + gfc_expr *e, *p = NULL; match m; tail = NULL; @@ -5261,6 +5562,15 @@ gfc_match_return (void) return MATCH_ERROR; } + if (gfc_find_state (COMP_CHANGE_TEAM)) + { + /* F2018, C1111: A RETURN statement shall not appear within a CHANGE TEAM + construct. */ + gfc_error ( + "Image control statement RETURN at %C in CHANGE TEAM-END TEAM block"); + return MATCH_ERROR; + } + if (gfc_match_eos () == MATCH_YES) goto done; @@ -6861,9 +7171,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; @@ -6882,12 +7194,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; @@ -6929,7 +7241,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) { @@ -6937,9 +7251,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; |