From: Tobias Burnus Date: Thu, 8 Sep 2011 06:38:13 +0000 (+0200) Subject: re PR fortran/44646 ([F08] Implement DO CONCURRENT) X-Git-Tag: releases/gcc-4.7.0~3862 X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=8c6a85e33bc6029579949a76acbb0590463d7c8b;p=thirdparty%2Fgcc.git re PR fortran/44646 ([F08] Implement DO CONCURRENT) gcc/fortran/ 2011-09-08 Tobias Burnus PR fortran/44646 * decl.c (gfc_match_entry, gfc_match_end): Handle * COMP_DO_CONCURRENT. * dump-parse-tree.c (show_code_node): Handle EXEC_DO_CONCURRENT. * gfortran.h (gfc_exec_op): Add EXEC_DO_CONCURRENT. * match.c (gfc_match_critical, match_exit_cycle, * gfc_match_stopcode, lock_unlock_statement, sync_statement, gfc_match_allocate, gfc_match_deallocate, gfc_match_return): Add DO CONCURRENT diagnostic. (gfc_match_do): Match DO CONCURRENT. (match_derived_type_spec, match_type_spec, gfc_free_forall_iterator, match_forall_iterator, match_forall_header, match_simple_forall, gfc_match_forall): Move up in the file. * parse.c (check_do_closure, parse_do_block): Handle do * concurrent. * parse.h (gfc_compile_state): Add COMP_DO_CONCURRENT. * resolve.c (do_concurrent_flag): New global variable. (resolve_function, pure_subroutine, resolve_branch, gfc_resolve_blocks, resolve_code, resolve_types): Add do concurrent diagnostic. * st.c (gfc_free_statement): Handle EXEC_DO_CONCURRENT. * trans-stmt.c (gfc_trans_do_concurrent): New function. (gfc_trans_forall_1): Handle do concurrent. * trans-stmt.h (gfc_trans_do_concurrent): New function * prototype. * trans.c (trans_code): Call it. * frontend-passes.c (gfc_code_walker): Handle * EXEC_DO_CONCURRENT. gcc/testsuite/ 2011-09-08 Tobias Burnus PR fortran/44646 * gfortran.dg/do_concurrent_1.f90: New. * gfortran.dg/do_concurrent_2.f90: New. From-SVN: r178677 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 53c2929bf741..042d057a393b 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,29 @@ +2011-09-08 Tobias Burnus + + PR fortran/44646 + * decl.c (gfc_match_entry, gfc_match_end): Handle COMP_DO_CONCURRENT. + * dump-parse-tree.c (show_code_node): Handle EXEC_DO_CONCURRENT. + * gfortran.h (gfc_exec_op): Add EXEC_DO_CONCURRENT. + * match.c (gfc_match_critical, match_exit_cycle, gfc_match_stopcode, + lock_unlock_statement, sync_statement, gfc_match_allocate, + gfc_match_deallocate, gfc_match_return): Add DO CONCURRENT diagnostic. + (gfc_match_do): Match DO CONCURRENT. + (match_derived_type_spec, match_type_spec, gfc_free_forall_iterator, + match_forall_iterator, match_forall_header, match_simple_forall, + gfc_match_forall): Move up in the file. + * parse.c (check_do_closure, parse_do_block): Handle do concurrent. + * parse.h (gfc_compile_state): Add COMP_DO_CONCURRENT. + * resolve.c (do_concurrent_flag): New global variable. + (resolve_function, pure_subroutine, resolve_branch, + gfc_resolve_blocks, resolve_code, resolve_types): Add do concurrent + diagnostic. + * st.c (gfc_free_statement): Handle EXEC_DO_CONCURRENT. + * trans-stmt.c (gfc_trans_do_concurrent): New function. + (gfc_trans_forall_1): Handle do concurrent. + * trans-stmt.h (gfc_trans_do_concurrent): New function prototype. + * trans.c (trans_code): Call it. + * frontend-passes.c (gfc_code_walker): Handle EXEC_DO_CONCURRENT. + 2011-09-07 Janus Weil PR fortran/48095 diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 18e2651c81d6..0ee257591134 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -5248,6 +5248,7 @@ gfc_match_entry (void) "an IF-THEN block"); break; case COMP_DO: + case COMP_DO_CONCURRENT: gfc_error ("ENTRY statement at %C cannot appear within " "a DO block"); break; @@ -5853,6 +5854,7 @@ gfc_match_end (gfc_statement *st) break; case COMP_DO: + case COMP_DO_CONCURRENT: *st = ST_ENDDO; target = " do"; eos_ok = 0; diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index ad8b5548071c..af2cd85a5617 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -1611,6 +1611,28 @@ show_code_node (int level, gfc_code *c) fputs ("END DO", dumpfile); break; + case EXEC_DO_CONCURRENT: + fputs ("DO CONCURRENT ", dumpfile); + for (fa = c->ext.forall_iterator; fa; fa = fa->next) + { + show_expr (fa->var); + fputc (' ', dumpfile); + show_expr (fa->start); + fputc (':', dumpfile); + show_expr (fa->end); + fputc (':', dumpfile); + show_expr (fa->stride); + + if (fa->next != NULL) + fputc (',', dumpfile); + } + show_expr (c->expr1); + + show_code (level + 1, c->block->next); + code_indent (level, c->label1); + fputs ("END DO", dumpfile); + break; + case EXEC_DO_WHILE: fputs ("DO WHILE ", dumpfile); show_expr (c->expr1); diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c index 8f2b1d1350d8..ab8e9e0607b2 100644 --- a/gcc/fortran/frontend-passes.c +++ b/gcc/fortran/frontend-passes.c @@ -1103,6 +1103,7 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn, } case EXEC_FORALL: + case EXEC_DO_CONCURRENT: { gfc_forall_iterator *fa; for (fa = co->ext.forall_iterator; fa; fa = fa->next) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index ac36d249912c..54e0b20580dc 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2052,10 +2052,10 @@ typedef enum EXEC_LABEL_ASSIGN, EXEC_POINTER_ASSIGN, EXEC_CRITICAL, EXEC_ERROR_STOP, EXEC_GOTO, EXEC_CALL, EXEC_COMPCALL, EXEC_ASSIGN_CALL, EXEC_RETURN, EXEC_ENTRY, EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, EXEC_INIT_ASSIGN, - EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, 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_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, diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 43aeb19f9392..4ea98b610175 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -1748,6 +1748,13 @@ gfc_match_critical (void) return MATCH_ERROR; } + if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS) + { + gfc_error ("Image control statement CRITICAL at %C in DO CONCURRENT " + "block"); + return MATCH_ERROR; + } + if (gfc_implicit_pure (NULL)) gfc_current_ns->proc_name->attr.implicit_pure = 0; @@ -1893,3598 +1900,3710 @@ error: } -/* Match a DO statement. */ +/* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of + an accessible derived type. */ -match -gfc_match_do (void) +static match +match_derived_type_spec (gfc_typespec *ts) { - gfc_iterator iter, *ip; - locus old_loc; - gfc_st_label *label; - match m; + char name[GFC_MAX_SYMBOL_LEN + 1]; + locus old_locus; + gfc_symbol *derived; - old_loc = gfc_current_locus; + old_locus = gfc_current_locus; - label = NULL; - iter.var = iter.start = iter.end = iter.step = NULL; + if (gfc_match ("%n", name) != MATCH_YES) + { + gfc_current_locus = old_locus; + return MATCH_NO; + } - m = gfc_match_label (); - if (m == MATCH_ERROR) - return m; + gfc_find_symbol (name, NULL, 1, &derived); - if (gfc_match (" do") != MATCH_YES) - return MATCH_NO; + if (derived && derived->attr.flavor == FL_DERIVED) + { + ts->type = BT_DERIVED; + ts->u.derived = derived; + return MATCH_YES; + } - m = gfc_match_st_label (&label); - if (m == MATCH_ERROR) - goto cleanup; + gfc_current_locus = old_locus; + return MATCH_NO; +} - /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */ - if (gfc_match_eos () == MATCH_YES) +/* Match a Fortran 2003 type-spec (F03:R401). This is similar to + gfc_match_decl_type_spec() from decl.c, with the following exceptions: + It only includes the intrinsic types from the Fortran 2003 standard + (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally, + the implicit_flag is not needed, so it was removed. Derived types are + identified by their name alone. */ + +static match +match_type_spec (gfc_typespec *ts) +{ + match m; + locus old_locus; + + gfc_clear_ts (ts); + gfc_gobble_whitespace (); + old_locus = gfc_current_locus; + + if (match_derived_type_spec (ts) == MATCH_YES) { - iter.end = gfc_get_logical_expr (gfc_default_logical_kind, NULL, true); - new_st.op = EXEC_DO_WHILE; - goto done; + /* Enforce F03:C401. */ + if (ts->u.derived->attr.abstract) + { + gfc_error ("Derived type '%s' at %L may not be ABSTRACT", + ts->u.derived->name, &old_locus); + return MATCH_ERROR; + } + return MATCH_YES; } - /* Match an optional comma, if no comma is found, a space is obligatory. */ - if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES) - return MATCH_NO; + if (gfc_match ("integer") == MATCH_YES) + { + ts->type = BT_INTEGER; + ts->kind = gfc_default_integer_kind; + goto kind_selector; + } - /* Check for balanced parens. */ - - if (gfc_match_parens () == MATCH_ERROR) - return MATCH_ERROR; + if (gfc_match ("real") == MATCH_YES) + { + ts->type = BT_REAL; + ts->kind = gfc_default_real_kind; + goto kind_selector; + } - /* See if we have a DO WHILE. */ - if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES) + if (gfc_match ("double precision") == MATCH_YES) { - new_st.op = EXEC_DO_WHILE; - goto done; + ts->type = BT_REAL; + ts->kind = gfc_default_double_kind; + return MATCH_YES; } - /* The abortive DO WHILE may have done something to the symbol - table, so we start over. */ - gfc_undo_symbols (); - gfc_current_locus = old_loc; + if (gfc_match ("complex") == MATCH_YES) + { + ts->type = BT_COMPLEX; + ts->kind = gfc_default_complex_kind; + goto kind_selector; + } - gfc_match_label (); /* This won't error. */ - gfc_match (" do "); /* This will work. */ + if (gfc_match ("character") == MATCH_YES) + { + ts->type = BT_CHARACTER; - gfc_match_st_label (&label); /* Can't error out. */ - gfc_match_char (','); /* Optional comma. */ + m = gfc_match_char_spec (ts); - m = gfc_match_iterator (&iter, 0); - if (m == MATCH_NO) - return MATCH_NO; - if (m == MATCH_ERROR) - goto cleanup; + if (m == MATCH_NO) + m = MATCH_YES; - iter.var->symtree->n.sym->attr.implied_index = 0; - gfc_check_do_variable (iter.var->symtree); + return m; + } - if (gfc_match_eos () != MATCH_YES) + if (gfc_match ("logical") == MATCH_YES) { - gfc_syntax_error (ST_DO); - goto cleanup; + ts->type = BT_LOGICAL; + ts->kind = gfc_default_logical_kind; + goto kind_selector; } - new_st.op = EXEC_DO; - -done: - if (label != NULL - && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE) - goto cleanup; + /* If a type is not matched, simply return MATCH_NO. */ + gfc_current_locus = old_locus; + return MATCH_NO; - new_st.label1 = label; +kind_selector: - if (new_st.op == EXEC_DO_WHILE) - new_st.expr1 = iter.end; - else + gfc_gobble_whitespace (); + if (gfc_peek_ascii_char () == '*') { - new_st.ext.iterator = ip = gfc_get_iterator (); - *ip = iter; + gfc_error ("Invalid type-spec at %C"); + return MATCH_ERROR; } - return MATCH_YES; + m = gfc_match_kind_spec (ts, false); -cleanup: - gfc_free_iterator (&iter, 0); + if (m == MATCH_NO) + m = MATCH_YES; /* No kind specifier found. */ - return MATCH_ERROR; + return m; } -/* Match an EXIT or CYCLE statement. */ +/******************** FORALL subroutines ********************/ -static match -match_exit_cycle (gfc_statement st, gfc_exec_op op) +/* Free a list of FORALL iterators. */ + +void +gfc_free_forall_iterator (gfc_forall_iterator *iter) { - gfc_state_data *p, *o; - gfc_symbol *sym; - match m; - int cnt; + gfc_forall_iterator *next; - if (gfc_match_eos () == MATCH_YES) - sym = NULL; - else + while (iter) { - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_symtree* stree; + next = iter->next; + gfc_free_expr (iter->var); + gfc_free_expr (iter->start); + gfc_free_expr (iter->end); + gfc_free_expr (iter->stride); + free (iter); + iter = next; + } +} - m = gfc_match ("% %n%t", name); - if (m == MATCH_ERROR) - return MATCH_ERROR; - if (m == MATCH_NO) - { - gfc_syntax_error (st); - return MATCH_ERROR; - } - /* Find the corresponding symbol. If there's a BLOCK statement - between here and the label, it is not in gfc_current_ns but a parent - namespace! */ - stree = gfc_find_symtree_in_proc (name, gfc_current_ns); - if (!stree) - { - gfc_error ("Name '%s' in %s statement at %C is unknown", - name, gfc_ascii_statement (st)); - return MATCH_ERROR; - } +/* Match an iterator as part of a FORALL statement. The format is: - sym = stree->n.sym; - if (sym->attr.flavor != FL_LABEL) - { - gfc_error ("Name '%s' in %s statement at %C is not a construct name", - name, gfc_ascii_statement (st)); - return MATCH_ERROR; - } - } + = :[:] - /* Find the loop specified by the label (or lack of a label). */ - for (o = NULL, p = gfc_state_stack; p; p = p->previous) - if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK) - o = p; - else if (p->state == COMP_CRITICAL) - { - gfc_error("%s statement at %C leaves CRITICAL construct", - gfc_ascii_statement (st)); - return MATCH_ERROR; - } - else if ((sym && sym == p->sym) || (!sym && p->state == COMP_DO)) - break; + On MATCH_NO, the caller tests for the possibility that there is a + scalar mask expression. */ - if (p == NULL) - { - if (sym == NULL) - gfc_error ("%s statement at %C is not within a construct", - gfc_ascii_statement (st)); - else - gfc_error ("%s statement at %C is not within construct '%s'", - gfc_ascii_statement (st), sym->name); +static match +match_forall_iterator (gfc_forall_iterator **result) +{ + gfc_forall_iterator *iter; + locus where; + match m; - return MATCH_ERROR; - } + where = gfc_current_locus; + iter = XCNEW (gfc_forall_iterator); - /* Special checks for EXIT from non-loop constructs. */ - switch (p->state) + m = gfc_match_expr (&iter->var); + if (m != MATCH_YES) + goto cleanup; + + if (gfc_match_char ('=') != MATCH_YES + || iter->var->expr_type != EXPR_VARIABLE) { - case COMP_DO: - break; + m = MATCH_NO; + goto cleanup; + } - case COMP_CRITICAL: - /* This is already handled above. */ - gcc_unreachable (); + m = gfc_match_expr (&iter->start); + if (m != MATCH_YES) + goto cleanup; - case COMP_ASSOCIATE: - case COMP_BLOCK: - case COMP_IF: - case COMP_SELECT: - case COMP_SELECT_TYPE: - gcc_assert (sym); - if (op == EXEC_CYCLE) - { - gfc_error ("CYCLE statement at %C is not applicable to non-loop" - " construct '%s'", sym->name); - return MATCH_ERROR; - } - gcc_assert (op == EXEC_EXIT); - if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: EXIT statement with no" - " do-construct-name at %C") == FAILURE) - return MATCH_ERROR; - break; - - default: - gfc_error ("%s statement at %C is not applicable to construct '%s'", - gfc_ascii_statement (st), sym->name); - return MATCH_ERROR; - } + if (gfc_match_char (':') != MATCH_YES) + goto syntax; - if (o != NULL) - { - gfc_error ("%s statement at %C leaving OpenMP structured block", - gfc_ascii_statement (st)); - return MATCH_ERROR; - } + m = gfc_match_expr (&iter->end); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; - for (o = p, cnt = 0; o->state == COMP_DO && o->previous != NULL; cnt++) - o = o->previous; - if (cnt > 0 - && o != NULL - && o->state == COMP_OMP_STRUCTURED_BLOCK - && (o->head->op == EXEC_OMP_DO - || o->head->op == EXEC_OMP_PARALLEL_DO)) + if (gfc_match_char (':') == MATCH_NO) + iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); + else { - int collapse = 1; - gcc_assert (o->head->next != NULL - && (o->head->next->op == EXEC_DO - || o->head->next->op == EXEC_DO_WHILE) - && o->previous != NULL - && o->previous->tail->op == o->head->op); - if (o->previous->tail->ext.omp_clauses != NULL - && o->previous->tail->ext.omp_clauses->collapse > 1) - collapse = o->previous->tail->ext.omp_clauses->collapse; - if (st == ST_EXIT && cnt <= collapse) - { - gfc_error ("EXIT statement at %C terminating !$OMP DO loop"); - return MATCH_ERROR; - } - if (st == ST_CYCLE && cnt < collapse) - { - gfc_error ("CYCLE statement at %C to non-innermost collapsed" - " !$OMP DO loop"); - return MATCH_ERROR; - } + m = gfc_match_expr (&iter->stride); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; } - /* Save the first statement in the construct - needed by the backend. */ - new_st.ext.which_construct = p->construct; - - new_st.op = op; + /* Mark the iteration variable's symbol as used as a FORALL index. */ + iter->var->symtree->n.sym->forall_index = true; + *result = iter; return MATCH_YES; -} - - -/* Match the EXIT statement. */ - -match -gfc_match_exit (void) -{ - return match_exit_cycle (ST_EXIT, EXEC_EXIT); -} +syntax: + gfc_error ("Syntax error in FORALL iterator at %C"); + m = MATCH_ERROR; -/* Match the CYCLE statement. */ +cleanup: -match -gfc_match_cycle (void) -{ - return match_exit_cycle (ST_CYCLE, EXEC_CYCLE); + gfc_current_locus = where; + gfc_free_forall_iterator (iter); + return m; } -/* Match a number or character constant after an (ALL) STOP or PAUSE statement. */ +/* Match the header of a FORALL statement. */ static match -gfc_match_stopcode (gfc_statement st) +match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask) { - gfc_expr *e; + gfc_forall_iterator *head, *tail, *new_iter; + gfc_expr *msk; match m; - e = NULL; + gfc_gobble_whitespace (); - if (gfc_match_eos () != MATCH_YES) - { - m = gfc_match_init_expr (&e); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; + head = tail = NULL; + msk = NULL; - if (gfc_match_eos () != MATCH_YES) - goto syntax; - } + if (gfc_match_char ('(') != MATCH_YES) + return MATCH_NO; - if (gfc_pure (NULL)) - { - gfc_error ("%s statement not allowed in PURE procedure at %C", - gfc_ascii_statement (st)); - goto cleanup; - } + m = match_forall_iterator (&new_iter); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; - if (gfc_implicit_pure (NULL)) - gfc_current_ns->proc_name->attr.implicit_pure = 0; + head = tail = new_iter; - if (st == ST_STOP && gfc_find_state (COMP_CRITICAL) == SUCCESS) + for (;;) { - gfc_error ("Image control statement STOP at %C in CRITICAL block"); - goto cleanup; - } + if (gfc_match_char (',') != MATCH_YES) + break; - if (e != NULL) - { - if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER)) - { - gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type", - &e->where); - goto cleanup; - } + m = match_forall_iterator (&new_iter); + if (m == MATCH_ERROR) + goto cleanup; - if (e->rank != 0) + if (m == MATCH_YES) { - gfc_error ("STOP code at %L must be scalar", - &e->where); - goto cleanup; + tail->next = new_iter; + tail = new_iter; + continue; } - if (e->ts.type == BT_CHARACTER - && e->ts.kind != gfc_default_character_kind) - { - gfc_error ("STOP code at %L must be default character KIND=%d", - &e->where, (int) gfc_default_character_kind); - goto cleanup; - } + /* Have to have a mask expression. */ - if (e->ts.type == BT_INTEGER - && e->ts.kind != gfc_default_integer_kind) - { - gfc_error ("STOP code at %L must be default integer KIND=%d", - &e->where, (int) gfc_default_integer_kind); - goto cleanup; - } - } + m = gfc_match_expr (&msk); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; - switch (st) - { - case ST_STOP: - new_st.op = EXEC_STOP; - break; - case ST_ERROR_STOP: - new_st.op = EXEC_ERROR_STOP; break; - case ST_PAUSE: - new_st.op = EXEC_PAUSE; - break; - default: - gcc_unreachable (); } - new_st.expr1 = e; - new_st.ext.stop_code = -1; + if (gfc_match_char (')') == MATCH_NO) + goto syntax; + *phead = head; + *mask = msk; return MATCH_YES; syntax: - gfc_syntax_error (st); + gfc_syntax_error (ST_FORALL); cleanup: + gfc_free_expr (msk); + gfc_free_forall_iterator (head); - gfc_free_expr (e); return MATCH_ERROR; } +/* Match the rest of a simple FORALL statement that follows an + IF statement. */ -/* Match the (deprecated) PAUSE statement. */ - -match -gfc_match_pause (void) +static match +match_simple_forall (void) { + gfc_forall_iterator *head; + gfc_expr *mask; + gfc_code *c; match m; - m = gfc_match_stopcode (ST_PAUSE); - if (m == MATCH_YES) - { - if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: PAUSE statement" - " at %C") - == FAILURE) - m = MATCH_ERROR; - } - return m; -} + mask = NULL; + head = NULL; + c = NULL; + m = match_forall_header (&head, &mask); -/* Match the STOP statement. */ + if (m == MATCH_NO) + goto syntax; + if (m != MATCH_YES) + goto cleanup; -match -gfc_match_stop (void) -{ - return gfc_match_stopcode (ST_STOP); -} + m = gfc_match_assignment (); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + { + m = gfc_match_pointer_assignment (); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + } -/* Match the ERROR STOP statement. */ + c = gfc_get_code (); + *c = new_st; + c->loc = gfc_current_locus; -match -gfc_match_error_stop (void) -{ - if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: ERROR STOP statement at %C") - == FAILURE) - return MATCH_ERROR; + if (gfc_match_eos () != MATCH_YES) + goto syntax; - return gfc_match_stopcode (ST_ERROR_STOP); -} + gfc_clear_new_st (); + new_st.op = EXEC_FORALL; + new_st.expr1 = mask; + new_st.ext.forall_iterator = head; + new_st.block = gfc_get_code (); + new_st.block->op = EXEC_FORALL; + new_st.block->next = c; -/* Match LOCK/UNLOCK statement. Syntax: - LOCK ( lock-variable [ , lock-stat-list ] ) - UNLOCK ( lock-variable [ , sync-stat-list ] ) - where lock-stat is ACQUIRED_LOCK or sync-stat - and sync-stat is STAT= or ERRMSG=. */ + return MATCH_YES; -static match -lock_unlock_statement (gfc_statement st) -{ - match m; - gfc_expr *tmp, *lockvar, *acq_lock, *stat, *errmsg; - bool saw_acq_lock, saw_stat, saw_errmsg; +syntax: + gfc_syntax_error (ST_FORALL); - tmp = lockvar = acq_lock = stat = errmsg = NULL; - saw_acq_lock = saw_stat = saw_errmsg = false; +cleanup: + gfc_free_forall_iterator (head); + gfc_free_expr (mask); - if (gfc_pure (NULL)) - { - gfc_error ("Image control statement SYNC at %C in PURE procedure"); - return MATCH_ERROR; - } + return MATCH_ERROR; +} - if (gfc_implicit_pure (NULL)) - gfc_current_ns->proc_name->attr.implicit_pure = 0; - if (gfc_option.coarray == GFC_FCOARRAY_NONE) - { - gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); - return MATCH_ERROR; - } +/* Match a FORALL statement. */ - if (gfc_find_state (COMP_CRITICAL) == SUCCESS) - { - gfc_error ("Image control statement SYNC at %C in CRITICAL block"); - return MATCH_ERROR; - } +match +gfc_match_forall (gfc_statement *st) +{ + gfc_forall_iterator *head; + gfc_expr *mask; + gfc_code *c; + match m0, m; - if (gfc_match_char ('(') != MATCH_YES) - goto syntax; + head = NULL; + mask = NULL; + c = NULL; - if (gfc_match ("%e", &lockvar) != MATCH_YES) - goto syntax; - m = gfc_match_char (','); + m0 = gfc_match_label (); + if (m0 == MATCH_ERROR) + return MATCH_ERROR; + + m = gfc_match (" forall"); + if (m != MATCH_YES) + return m; + + m = match_forall_header (&head, &mask); if (m == MATCH_ERROR) - goto syntax; + goto cleanup; if (m == MATCH_NO) + goto syntax; + + if (gfc_match_eos () == MATCH_YES) { - m = gfc_match_char (')'); - if (m == MATCH_YES) - goto done; - goto syntax; + *st = ST_FORALL_BLOCK; + new_st.op = EXEC_FORALL; + new_st.expr1 = mask; + new_st.ext.forall_iterator = head; + return MATCH_YES; } - for (;;) + m = gfc_match_assignment (); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) { - m = gfc_match (" stat = %v", &tmp); + m = gfc_match_pointer_assignment (); if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) goto syntax; - if (m == MATCH_YES) - { - if (saw_stat) - { - gfc_error ("Redundant STAT tag found at %L ", &tmp->where); - goto cleanup; - } - stat = tmp; - saw_stat = true; + } - m = gfc_match_char (','); - if (m == MATCH_YES) - continue; + c = gfc_get_code (); + *c = new_st; + c->loc = gfc_current_locus; - tmp = NULL; - break; - } + gfc_clear_new_st (); + new_st.op = EXEC_FORALL; + new_st.expr1 = mask; + new_st.ext.forall_iterator = head; + new_st.block = gfc_get_code (); + new_st.block->op = EXEC_FORALL; + new_st.block->next = c; - m = gfc_match (" errmsg = %v", &tmp); - if (m == MATCH_ERROR) - goto syntax; - if (m == MATCH_YES) - { - if (saw_errmsg) - { - gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where); - goto cleanup; - } - errmsg = tmp; - saw_errmsg = true; + *st = ST_FORALL; + return MATCH_YES; - m = gfc_match_char (','); - if (m == MATCH_YES) - continue; +syntax: + gfc_syntax_error (ST_FORALL); - tmp = NULL; - break; - } +cleanup: + gfc_free_forall_iterator (head); + gfc_free_expr (mask); + gfc_free_statements (c); + return MATCH_NO; +} - m = gfc_match (" acquired_lock = %v", &tmp); - if (m == MATCH_ERROR || st == ST_UNLOCK) - goto syntax; - if (m == MATCH_YES) - { - if (saw_acq_lock) - { - gfc_error ("Redundant ACQUIRED_LOCK tag found at %L ", - &tmp->where); - goto cleanup; - } - acq_lock = tmp; - saw_acq_lock = true; - m = gfc_match_char (','); - if (m == MATCH_YES) - continue; +/* Match a DO statement. */ - tmp = NULL; - break; - } +match +gfc_match_do (void) +{ + gfc_iterator iter, *ip; + locus old_loc; + gfc_st_label *label; + match m; - break; - } + old_loc = gfc_current_locus; + + label = NULL; + iter.var = iter.start = iter.end = iter.step = NULL; + m = gfc_match_label (); if (m == MATCH_ERROR) - goto syntax; + return m; - if (gfc_match (" )%t") != MATCH_YES) - goto syntax; + if (gfc_match (" do") != MATCH_YES) + return MATCH_NO; -done: - switch (st) + m = gfc_match_st_label (&label); + if (m == MATCH_ERROR) + goto cleanup; + + /* Match an infinite DO, make it like a DO WHILE(.TRUE.). */ + + if (gfc_match_eos () == MATCH_YES) { - case ST_LOCK: - new_st.op = EXEC_LOCK; - break; - case ST_UNLOCK: - new_st.op = EXEC_UNLOCK; - break; - default: - gcc_unreachable (); + iter.end = gfc_get_logical_expr (gfc_default_logical_kind, NULL, true); + new_st.op = EXEC_DO_WHILE; + goto done; } - new_st.expr1 = lockvar; - new_st.expr2 = stat; - new_st.expr3 = errmsg; - new_st.expr4 = acq_lock; + /* Match an optional comma, if no comma is found, a space is obligatory. */ + if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES) + return MATCH_NO; - return MATCH_YES; + /* Check for balanced parens. */ + + if (gfc_match_parens () == MATCH_ERROR) + return MATCH_ERROR; -syntax: - gfc_syntax_error (st); - -cleanup: - gfc_free_expr (tmp); - gfc_free_expr (lockvar); - gfc_free_expr (acq_lock); - gfc_free_expr (stat); - gfc_free_expr (errmsg); - - return MATCH_ERROR; -} - - -match -gfc_match_lock (void) -{ - if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: LOCK statement at %C") - == FAILURE) - return MATCH_ERROR; - - return lock_unlock_statement (ST_LOCK); -} - - -match -gfc_match_unlock (void) -{ - if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: UNLOCK statement at %C") - == FAILURE) - return MATCH_ERROR; - - return lock_unlock_statement (ST_UNLOCK); -} + if (gfc_match (" concurrent") == MATCH_YES) + { + gfc_forall_iterator *head; + gfc_expr *mask; + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: DO CONCURRENT " + "construct at %C") == FAILURE) + return MATCH_ERROR; -/* Match SYNC ALL/IMAGES/MEMORY statement. Syntax: - SYNC ALL [(sync-stat-list)] - SYNC MEMORY [(sync-stat-list)] - SYNC IMAGES (image-set [, sync-stat-list] ) - with sync-stat is int-expr or *. */ -static match -sync_statement (gfc_statement st) -{ - match m; - gfc_expr *tmp, *imageset, *stat, *errmsg; - bool saw_stat, saw_errmsg; + mask = NULL; + head = NULL; + m = match_forall_header (&head, &mask); - tmp = imageset = stat = errmsg = NULL; - saw_stat = saw_errmsg = false; + if (m == MATCH_NO) + return m; + if (m == MATCH_ERROR) + goto concurr_cleanup; - if (gfc_pure (NULL)) - { - gfc_error ("Image control statement SYNC at %C in PURE procedure"); - return MATCH_ERROR; - } + if (gfc_match_eos () != MATCH_YES) + goto concurr_cleanup; - if (gfc_implicit_pure (NULL)) - gfc_current_ns->proc_name->attr.implicit_pure = 0; + if (label != NULL + && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE) + goto concurr_cleanup; - if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SYNC statement at %C") - == FAILURE) - return MATCH_ERROR; + new_st.label1 = label; + new_st.op = EXEC_DO_CONCURRENT; + new_st.expr1 = mask; + new_st.ext.forall_iterator = head; - if (gfc_option.coarray == GFC_FCOARRAY_NONE) - { - gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); - return MATCH_ERROR; - } + return MATCH_YES; - if (gfc_find_state (COMP_CRITICAL) == SUCCESS) - { - gfc_error ("Image control statement SYNC at %C in CRITICAL block"); +concurr_cleanup: + gfc_syntax_error (ST_DO); + gfc_free_expr (mask); + gfc_free_forall_iterator (head); return MATCH_ERROR; } - if (gfc_match_eos () == MATCH_YES) + /* See if we have a DO WHILE. */ + if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES) { - if (st == ST_SYNC_IMAGES) - goto syntax; + new_st.op = EXEC_DO_WHILE; goto done; } - if (gfc_match_char ('(') != MATCH_YES) - goto syntax; - - if (st == ST_SYNC_IMAGES) - { - /* Denote '*' as imageset == NULL. */ - m = gfc_match_char ('*'); - if (m == MATCH_ERROR) - goto syntax; - if (m == MATCH_NO) - { - if (gfc_match ("%e", &imageset) != MATCH_YES) - goto syntax; - } - 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 = gfc_match (" stat = %v", &tmp); - if (m == MATCH_ERROR) - goto syntax; - if (m == MATCH_YES) - { - if (saw_stat) - { - gfc_error ("Redundant STAT tag found at %L ", &tmp->where); - goto cleanup; - } - stat = tmp; - saw_stat = true; - - if (gfc_match_char (',') == MATCH_YES) - continue; + /* The abortive DO WHILE may have done something to the symbol + table, so we start over. */ + gfc_undo_symbols (); + gfc_current_locus = old_loc; - tmp = NULL; - break; - } + gfc_match_label (); /* This won't error. */ + gfc_match (" do "); /* This will work. */ - m = gfc_match (" errmsg = %v", &tmp); - if (m == MATCH_ERROR) - goto syntax; - if (m == MATCH_YES) - { - if (saw_errmsg) - { - gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where); - goto cleanup; - } - errmsg = tmp; - saw_errmsg = true; + gfc_match_st_label (&label); /* Can't error out. */ + gfc_match_char (','); /* Optional comma. */ - if (gfc_match_char (',') == MATCH_YES) - continue; + m = gfc_match_iterator (&iter, 0); + if (m == MATCH_NO) + return MATCH_NO; + if (m == MATCH_ERROR) + goto cleanup; - tmp = NULL; - break; - } + iter.var->symtree->n.sym->attr.implied_index = 0; + gfc_check_do_variable (iter.var->symtree); - break; + if (gfc_match_eos () != MATCH_YES) + { + gfc_syntax_error (ST_DO); + goto cleanup; } - if (m == MATCH_ERROR) - goto syntax; - - if (gfc_match (" )%t") != MATCH_YES) - goto syntax; + new_st.op = EXEC_DO; done: - switch (st) + if (label != NULL + && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE) + goto cleanup; + + new_st.label1 = label; + + if (new_st.op == EXEC_DO_WHILE) + new_st.expr1 = iter.end; + else { - case ST_SYNC_ALL: - new_st.op = EXEC_SYNC_ALL; - break; - case ST_SYNC_IMAGES: - new_st.op = EXEC_SYNC_IMAGES; - break; - case ST_SYNC_MEMORY: - new_st.op = EXEC_SYNC_MEMORY; - break; - default: - gcc_unreachable (); + new_st.ext.iterator = ip = gfc_get_iterator (); + *ip = iter; } - new_st.expr1 = imageset; - new_st.expr2 = stat; - new_st.expr3 = errmsg; - return MATCH_YES; -syntax: - gfc_syntax_error (st); - cleanup: - gfc_free_expr (tmp); - gfc_free_expr (imageset); - gfc_free_expr (stat); - gfc_free_expr (errmsg); + gfc_free_iterator (&iter, 0); return MATCH_ERROR; } -/* Match SYNC ALL statement. */ - -match -gfc_match_sync_all (void) -{ - return sync_statement (ST_SYNC_ALL); -} - - -/* Match SYNC IMAGES statement. */ +/* Match an EXIT or CYCLE statement. */ -match -gfc_match_sync_images (void) +static match +match_exit_cycle (gfc_statement st, gfc_exec_op op) { - return sync_statement (ST_SYNC_IMAGES); -} + gfc_state_data *p, *o; + gfc_symbol *sym; + match m; + int cnt; + if (gfc_match_eos () == MATCH_YES) + sym = NULL; + else + { + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symtree* stree; -/* Match SYNC MEMORY statement. */ + m = gfc_match ("% %n%t", name); + if (m == MATCH_ERROR) + return MATCH_ERROR; + if (m == MATCH_NO) + { + gfc_syntax_error (st); + return MATCH_ERROR; + } -match -gfc_match_sync_memory (void) -{ - return sync_statement (ST_SYNC_MEMORY); -} + /* Find the corresponding symbol. If there's a BLOCK statement + between here and the label, it is not in gfc_current_ns but a parent + namespace! */ + stree = gfc_find_symtree_in_proc (name, gfc_current_ns); + if (!stree) + { + gfc_error ("Name '%s' in %s statement at %C is unknown", + name, gfc_ascii_statement (st)); + return MATCH_ERROR; + } + sym = stree->n.sym; + if (sym->attr.flavor != FL_LABEL) + { + gfc_error ("Name '%s' in %s statement at %C is not a construct name", + name, gfc_ascii_statement (st)); + return MATCH_ERROR; + } + } -/* Match a CONTINUE statement. */ + /* Find the loop specified by the label (or lack of a label). */ + for (o = NULL, p = gfc_state_stack; p; p = p->previous) + if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK) + o = p; + else if (p->state == COMP_CRITICAL) + { + gfc_error("%s statement at %C leaves CRITICAL construct", + gfc_ascii_statement (st)); + return MATCH_ERROR; + } + else if (p->state == COMP_DO_CONCURRENT + && (op == EXEC_EXIT || (sym && sym != p->sym))) + { + /* F2008, C821 & C845. */ + gfc_error("%s statement at %C leaves DO CONCURRENT construct", + gfc_ascii_statement (st)); + return MATCH_ERROR; + } + else if ((sym && sym == p->sym) + || (!sym && (p->state == COMP_DO + || p->state == COMP_DO_CONCURRENT))) + break; -match -gfc_match_continue (void) -{ - if (gfc_match_eos () != MATCH_YES) + if (p == NULL) { - gfc_syntax_error (ST_CONTINUE); + if (sym == NULL) + gfc_error ("%s statement at %C is not within a construct", + gfc_ascii_statement (st)); + else + gfc_error ("%s statement at %C is not within construct '%s'", + gfc_ascii_statement (st), sym->name); + return MATCH_ERROR; } - new_st.op = EXEC_CONTINUE; + /* Special checks for EXIT from non-loop constructs. */ + switch (p->state) + { + case COMP_DO: + case COMP_DO_CONCURRENT: + break; + + case COMP_CRITICAL: + /* This is already handled above. */ + gcc_unreachable (); + + case COMP_ASSOCIATE: + case COMP_BLOCK: + case COMP_IF: + case COMP_SELECT: + case COMP_SELECT_TYPE: + gcc_assert (sym); + if (op == EXEC_CYCLE) + { + gfc_error ("CYCLE statement at %C is not applicable to non-loop" + " construct '%s'", sym->name); + return MATCH_ERROR; + } + gcc_assert (op == EXEC_EXIT); + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: EXIT statement with no" + " do-construct-name at %C") == FAILURE) + return MATCH_ERROR; + break; + + default: + gfc_error ("%s statement at %C is not applicable to construct '%s'", + gfc_ascii_statement (st), sym->name); + return MATCH_ERROR; + } + + if (o != NULL) + { + gfc_error ("%s statement at %C leaving OpenMP structured block", + gfc_ascii_statement (st)); + return MATCH_ERROR; + } + + for (o = p, cnt = 0; o->state == COMP_DO && o->previous != NULL; cnt++) + o = o->previous; + if (cnt > 0 + && o != NULL + && o->state == COMP_OMP_STRUCTURED_BLOCK + && (o->head->op == EXEC_OMP_DO + || o->head->op == EXEC_OMP_PARALLEL_DO)) + { + int collapse = 1; + gcc_assert (o->head->next != NULL + && (o->head->next->op == EXEC_DO + || o->head->next->op == EXEC_DO_WHILE) + && o->previous != NULL + && o->previous->tail->op == o->head->op); + if (o->previous->tail->ext.omp_clauses != NULL + && o->previous->tail->ext.omp_clauses->collapse > 1) + collapse = o->previous->tail->ext.omp_clauses->collapse; + if (st == ST_EXIT && cnt <= collapse) + { + gfc_error ("EXIT statement at %C terminating !$OMP DO loop"); + return MATCH_ERROR; + } + if (st == ST_CYCLE && cnt < collapse) + { + gfc_error ("CYCLE statement at %C to non-innermost collapsed" + " !$OMP DO loop"); + return MATCH_ERROR; + } + } + + /* Save the first statement in the construct - needed by the backend. */ + new_st.ext.which_construct = p->construct; + + new_st.op = op; + return MATCH_YES; } -/* Match the (deprecated) ASSIGN statement. */ +/* Match the EXIT statement. */ match -gfc_match_assign (void) +gfc_match_exit (void) { - gfc_expr *expr; - gfc_st_label *label; + return match_exit_cycle (ST_EXIT, EXEC_EXIT); +} - if (gfc_match (" %l", &label) == MATCH_YES) - { - if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE) - return MATCH_ERROR; - if (gfc_match (" to %v%t", &expr) == MATCH_YES) - { - if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGN " - "statement at %C") - == FAILURE) - return MATCH_ERROR; - expr->symtree->n.sym->attr.assign = 1; +/* Match the CYCLE statement. */ - new_st.op = EXEC_LABEL_ASSIGN; - new_st.label1 = label; - new_st.expr1 = expr; - return MATCH_YES; - } - } - return MATCH_NO; +match +gfc_match_cycle (void) +{ + return match_exit_cycle (ST_CYCLE, EXEC_CYCLE); } -/* Match the GO TO statement. As a computed GOTO statement is - matched, it is transformed into an equivalent SELECT block. No - tree is necessary, and the resulting jumps-to-jumps are - specifically optimized away by the back end. */ +/* Match a number or character constant after an (ALL) STOP or PAUSE statement. */ -match -gfc_match_goto (void) +static match +gfc_match_stopcode (gfc_statement st) { - gfc_code *head, *tail; - gfc_expr *expr; - gfc_case *cp; - gfc_st_label *label; - int i; + gfc_expr *e; match m; - if (gfc_match (" %l%t", &label) == MATCH_YES) + e = NULL; + + if (gfc_match_eos () != MATCH_YES) { - if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE) - return MATCH_ERROR; + m = gfc_match_init_expr (&e); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; - new_st.op = EXEC_GOTO; - new_st.label1 = label; - return MATCH_YES; + if (gfc_match_eos () != MATCH_YES) + goto syntax; } - /* The assigned GO TO statement. */ - - if (gfc_match_variable (&expr, 0) == MATCH_YES) + if (gfc_pure (NULL)) { - if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: Assigned GOTO " - "statement at %C") - == FAILURE) - return MATCH_ERROR; + gfc_error ("%s statement not allowed in PURE procedure at %C", + gfc_ascii_statement (st)); + goto cleanup; + } - new_st.op = EXEC_GOTO; - new_st.expr1 = expr; + if (gfc_implicit_pure (NULL)) + gfc_current_ns->proc_name->attr.implicit_pure = 0; - if (gfc_match_eos () == MATCH_YES) - return MATCH_YES; + if (st == ST_STOP && gfc_find_state (COMP_CRITICAL) == SUCCESS) + { + gfc_error ("Image control statement STOP at %C in CRITICAL block"); + goto cleanup; + } + if (st == ST_STOP && gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS) + { + gfc_error ("Image control statement STOP at %C in DO CONCURRENT block"); + goto cleanup; + } - /* Match label list. */ - gfc_match_char (','); - if (gfc_match_char ('(') != MATCH_YES) + if (e != NULL) + { + if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER)) { - gfc_syntax_error (ST_GOTO); - return MATCH_ERROR; + gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type", + &e->where); + goto cleanup; } - head = tail = NULL; - do + if (e->rank != 0) { - m = gfc_match_st_label (&label); - if (m != MATCH_YES) - goto syntax; - - if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE) - goto cleanup; - - if (head == NULL) - head = tail = gfc_get_code (); - else - { - tail->block = gfc_get_code (); - tail = tail->block; - } - - tail->label1 = label; - tail->op = EXEC_GOTO; + gfc_error ("STOP code at %L must be scalar", + &e->where); + goto cleanup; } - while (gfc_match_char (',') == MATCH_YES); - if (gfc_match (")%t") != MATCH_YES) - goto syntax; - - if (head == NULL) + if (e->ts.type == BT_CHARACTER + && e->ts.kind != gfc_default_character_kind) { - gfc_error ("Statement label list in GOTO at %C cannot be empty"); - goto syntax; + gfc_error ("STOP code at %L must be default character KIND=%d", + &e->where, (int) gfc_default_character_kind); + goto cleanup; } - new_st.block = head; - return MATCH_YES; + if (e->ts.type == BT_INTEGER + && e->ts.kind != gfc_default_integer_kind) + { + gfc_error ("STOP code at %L must be default integer KIND=%d", + &e->where, (int) gfc_default_integer_kind); + goto cleanup; + } } - /* Last chance is a computed GO TO statement. */ - if (gfc_match_char ('(') != MATCH_YES) + switch (st) { - gfc_syntax_error (ST_GOTO); - return MATCH_ERROR; - } - - head = tail = NULL; - i = 1; - - do - { - m = gfc_match_st_label (&label); - if (m != MATCH_YES) - goto syntax; - - if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE) - goto cleanup; - - if (head == NULL) - head = tail = gfc_get_code (); - else - { - tail->block = gfc_get_code (); - tail = tail->block; - } - - cp = gfc_get_case (); - cp->low = cp->high = gfc_get_int_expr (gfc_default_integer_kind, - NULL, i++); - - tail->op = EXEC_SELECT; - tail->ext.block.case_list = cp; - - tail->next = gfc_get_code (); - tail->next->op = EXEC_GOTO; - tail->next->label1 = label; - } - while (gfc_match_char (',') == MATCH_YES); - - if (gfc_match_char (')') != MATCH_YES) - goto syntax; - - if (head == NULL) - { - gfc_error ("Statement label list in GOTO at %C cannot be empty"); - goto syntax; + case ST_STOP: + new_st.op = EXEC_STOP; + break; + case ST_ERROR_STOP: + new_st.op = EXEC_ERROR_STOP; + break; + case ST_PAUSE: + new_st.op = EXEC_PAUSE; + break; + default: + gcc_unreachable (); } - /* Get the rest of the statement. */ - gfc_match_char (','); - - if (gfc_match (" %e%t", &expr) != MATCH_YES) - goto syntax; - - if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Computed GOTO " - "at %C") == FAILURE) - return MATCH_ERROR; - - /* At this point, a computed GOTO has been fully matched and an - equivalent SELECT statement constructed. */ - - new_st.op = EXEC_SELECT; - new_st.expr1 = NULL; + new_st.expr1 = e; + new_st.ext.stop_code = -1; - /* Hack: For a "real" SELECT, the expression is in expr. We put - it in expr2 so we can distinguish then and produce the correct - diagnostics. */ - new_st.expr2 = expr; - new_st.block = head; return MATCH_YES; syntax: - gfc_syntax_error (ST_GOTO); + gfc_syntax_error (st); + cleanup: - gfc_free_statements (head); + + gfc_free_expr (e); return MATCH_ERROR; } -/* Frees a list of gfc_alloc structures. */ +/* Match the (deprecated) PAUSE statement. */ -void -gfc_free_alloc_list (gfc_alloc *p) +match +gfc_match_pause (void) { - gfc_alloc *q; + match m; - for (; p; p = q) + m = gfc_match_stopcode (ST_PAUSE); + if (m == MATCH_YES) { - q = p->next; - gfc_free_expr (p->expr); - free (p); + if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: PAUSE statement" + " at %C") + == FAILURE) + m = MATCH_ERROR; } + return m; } -/* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of - an accessible derived type. */ +/* Match the STOP statement. */ -static match -match_derived_type_spec (gfc_typespec *ts) +match +gfc_match_stop (void) { - char name[GFC_MAX_SYMBOL_LEN + 1]; - locus old_locus; - gfc_symbol *derived; - - old_locus = gfc_current_locus; + return gfc_match_stopcode (ST_STOP); +} - if (gfc_match ("%n", name) != MATCH_YES) - { - gfc_current_locus = old_locus; - return MATCH_NO; - } - gfc_find_symbol (name, NULL, 1, &derived); +/* Match the ERROR STOP statement. */ - if (derived && derived->attr.flavor == FL_DERIVED) - { - ts->type = BT_DERIVED; - ts->u.derived = derived; - return MATCH_YES; - } +match +gfc_match_error_stop (void) +{ + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: ERROR STOP statement at %C") + == FAILURE) + return MATCH_ERROR; - gfc_current_locus = old_locus; - return MATCH_NO; + return gfc_match_stopcode (ST_ERROR_STOP); } -/* Match a Fortran 2003 type-spec (F03:R401). This is similar to - gfc_match_decl_type_spec() from decl.c, with the following exceptions: - It only includes the intrinsic types from the Fortran 2003 standard - (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally, - the implicit_flag is not needed, so it was removed. Derived types are - identified by their name alone. */ +/* Match LOCK/UNLOCK statement. Syntax: + LOCK ( lock-variable [ , lock-stat-list ] ) + UNLOCK ( lock-variable [ , sync-stat-list ] ) + where lock-stat is ACQUIRED_LOCK or sync-stat + and sync-stat is STAT= or ERRMSG=. */ static match -match_type_spec (gfc_typespec *ts) +lock_unlock_statement (gfc_statement st) { match m; - locus old_locus; + gfc_expr *tmp, *lockvar, *acq_lock, *stat, *errmsg; + bool saw_acq_lock, saw_stat, saw_errmsg; - gfc_clear_ts (ts); - gfc_gobble_whitespace (); - old_locus = gfc_current_locus; + tmp = lockvar = acq_lock = stat = errmsg = NULL; + saw_acq_lock = saw_stat = saw_errmsg = false; - if (match_derived_type_spec (ts) == MATCH_YES) + if (gfc_pure (NULL)) { - /* Enforce F03:C401. */ - if (ts->u.derived->attr.abstract) - { - gfc_error ("Derived type '%s' at %L may not be ABSTRACT", - ts->u.derived->name, &old_locus); - return MATCH_ERROR; - } - return MATCH_YES; + gfc_error ("Image control statement %s at %C in PURE procedure", + st == ST_LOCK ? "LOCK" : "UNLOCK"); + return MATCH_ERROR; } - if (gfc_match ("integer") == MATCH_YES) + if (gfc_implicit_pure (NULL)) + gfc_current_ns->proc_name->attr.implicit_pure = 0; + + if (gfc_option.coarray == GFC_FCOARRAY_NONE) { - ts->type = BT_INTEGER; - ts->kind = gfc_default_integer_kind; - goto kind_selector; + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + return MATCH_ERROR; } - if (gfc_match ("real") == MATCH_YES) + if (gfc_find_state (COMP_CRITICAL) == SUCCESS) { - ts->type = BT_REAL; - ts->kind = gfc_default_real_kind; - goto kind_selector; + gfc_error ("Image control statement %s at %C in CRITICAL block", + st == ST_LOCK ? "LOCK" : "UNLOCK"); + return MATCH_ERROR; } - if (gfc_match ("double precision") == MATCH_YES) + if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS) { - ts->type = BT_REAL; - ts->kind = gfc_default_double_kind; - return MATCH_YES; + gfc_error ("Image control statement %s at %C in DO CONCURRENT block", + st == ST_LOCK ? "LOCK" : "UNLOCK"); + return MATCH_ERROR; } - if (gfc_match ("complex") == MATCH_YES) + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + if (gfc_match ("%e", &lockvar) != MATCH_YES) + goto syntax; + m = gfc_match_char (','); + if (m == MATCH_ERROR) + goto syntax; + if (m == MATCH_NO) { - ts->type = BT_COMPLEX; - ts->kind = gfc_default_complex_kind; - goto kind_selector; + m = gfc_match_char (')'); + if (m == MATCH_YES) + goto done; + goto syntax; } - if (gfc_match ("character") == MATCH_YES) + for (;;) { - ts->type = BT_CHARACTER; + m = gfc_match (" stat = %v", &tmp); + if (m == MATCH_ERROR) + goto syntax; + if (m == MATCH_YES) + { + if (saw_stat) + { + gfc_error ("Redundant STAT tag found at %L ", &tmp->where); + goto cleanup; + } + stat = tmp; + saw_stat = true; - m = gfc_match_char_spec (ts); + m = gfc_match_char (','); + if (m == MATCH_YES) + continue; - if (m == MATCH_NO) - m = MATCH_YES; + tmp = NULL; + break; + } - return m; - } + m = gfc_match (" errmsg = %v", &tmp); + if (m == MATCH_ERROR) + goto syntax; + if (m == MATCH_YES) + { + if (saw_errmsg) + { + gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where); + goto cleanup; + } + errmsg = tmp; + saw_errmsg = true; - if (gfc_match ("logical") == MATCH_YES) - { - ts->type = BT_LOGICAL; - ts->kind = gfc_default_logical_kind; - goto kind_selector; - } + m = gfc_match_char (','); + if (m == MATCH_YES) + continue; - /* If a type is not matched, simply return MATCH_NO. */ - gfc_current_locus = old_locus; - return MATCH_NO; + tmp = NULL; + break; + } -kind_selector: + m = gfc_match (" acquired_lock = %v", &tmp); + if (m == MATCH_ERROR || st == ST_UNLOCK) + goto syntax; + if (m == MATCH_YES) + { + if (saw_acq_lock) + { + gfc_error ("Redundant ACQUIRED_LOCK tag found at %L ", + &tmp->where); + goto cleanup; + } + acq_lock = tmp; + saw_acq_lock = true; - gfc_gobble_whitespace (); - if (gfc_peek_ascii_char () == '*') + m = gfc_match_char (','); + if (m == MATCH_YES) + continue; + + tmp = NULL; + break; + } + + break; + } + + if (m == MATCH_ERROR) + goto syntax; + + if (gfc_match (" )%t") != MATCH_YES) + goto syntax; + +done: + switch (st) { - gfc_error ("Invalid type-spec at %C"); - return MATCH_ERROR; + case ST_LOCK: + new_st.op = EXEC_LOCK; + break; + case ST_UNLOCK: + new_st.op = EXEC_UNLOCK; + break; + default: + gcc_unreachable (); } - m = gfc_match_kind_spec (ts, false); + new_st.expr1 = lockvar; + new_st.expr2 = stat; + new_st.expr3 = errmsg; + new_st.expr4 = acq_lock; - if (m == MATCH_NO) - m = MATCH_YES; /* No kind specifier found. */ + return MATCH_YES; - return m; +syntax: + gfc_syntax_error (st); + +cleanup: + gfc_free_expr (tmp); + gfc_free_expr (lockvar); + gfc_free_expr (acq_lock); + gfc_free_expr (stat); + gfc_free_expr (errmsg); + + return MATCH_ERROR; } -/* Match an ALLOCATE statement. */ +match +gfc_match_lock (void) +{ + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: LOCK statement at %C") + == FAILURE) + return MATCH_ERROR; + + return lock_unlock_statement (ST_LOCK); +} + match -gfc_match_allocate (void) +gfc_match_unlock (void) { - gfc_alloc *head, *tail; - gfc_expr *stat, *errmsg, *tmp, *source, *mold; - gfc_typespec ts; - gfc_symbol *sym; - match m; - locus old_locus, deferred_locus; - bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3; + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: UNLOCK statement at %C") + == FAILURE) + return MATCH_ERROR; - head = tail = NULL; - stat = errmsg = source = mold = tmp = NULL; - saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false; + return lock_unlock_statement (ST_UNLOCK); +} - if (gfc_match_char ('(') != MATCH_YES) - goto syntax; - /* Match an optional type-spec. */ - old_locus = gfc_current_locus; - m = match_type_spec (&ts); - if (m == MATCH_ERROR) - goto cleanup; - else if (m == MATCH_NO) - { - char name[GFC_MAX_SYMBOL_LEN + 3]; +/* Match SYNC ALL/IMAGES/MEMORY statement. Syntax: + SYNC ALL [(sync-stat-list)] + SYNC MEMORY [(sync-stat-list)] + SYNC IMAGES (image-set [, sync-stat-list] ) + with sync-stat is int-expr or *. */ - if (gfc_match ("%n :: ", name) == MATCH_YES) - { - gfc_error ("Error in type-spec at %L", &old_locus); - goto cleanup; - } +static match +sync_statement (gfc_statement st) +{ + match m; + gfc_expr *tmp, *imageset, *stat, *errmsg; + bool saw_stat, saw_errmsg; - ts.type = BT_UNKNOWN; + tmp = imageset = stat = errmsg = NULL; + saw_stat = saw_errmsg = false; + + if (gfc_pure (NULL)) + { + gfc_error ("Image control statement SYNC at %C in PURE procedure"); + return MATCH_ERROR; } - else + + if (gfc_implicit_pure (NULL)) + gfc_current_ns->proc_name->attr.implicit_pure = 0; + + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SYNC statement at %C") + == FAILURE) + return MATCH_ERROR; + + if (gfc_option.coarray == GFC_FCOARRAY_NONE) { - if (gfc_match (" :: ") == MATCH_YES) - { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: typespec in " - "ALLOCATE at %L", &old_locus) == FAILURE) - goto cleanup; + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + return MATCH_ERROR; + } - if (ts.deferred) - { - gfc_error ("Type-spec at %L cannot contain a deferred " - "type parameter", &old_locus); - goto cleanup; - } - } - else - { - ts.type = BT_UNKNOWN; - gfc_current_locus = old_locus; - } + if (gfc_find_state (COMP_CRITICAL) == SUCCESS) + { + gfc_error ("Image control statement SYNC at %C in CRITICAL block"); + return MATCH_ERROR; } - for (;;) + if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS) { - if (head == NULL) - head = tail = gfc_get_alloc (); - else - { - tail->next = gfc_get_alloc (); - tail = tail->next; - } + gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block"); + return MATCH_ERROR; + } - m = gfc_match_variable (&tail->expr, 0); - if (m == MATCH_NO) + if (gfc_match_eos () == MATCH_YES) + { + if (st == ST_SYNC_IMAGES) goto syntax; - if (m == MATCH_ERROR) - goto cleanup; + goto done; + } - if (gfc_check_do_variable (tail->expr->symtree)) - goto cleanup; + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; - if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym)) + if (st == ST_SYNC_IMAGES) + { + /* Denote '*' as imageset == NULL. */ + m = gfc_match_char ('*'); + if (m == MATCH_ERROR) + goto syntax; + if (m == MATCH_NO) { - gfc_error ("Bad allocate-object at %C for a PURE procedure"); - goto cleanup; + if (gfc_match ("%e", &imageset) != MATCH_YES) + goto syntax; } - - if (gfc_implicit_pure (NULL) - && gfc_impure_variable (tail->expr->symtree->n.sym)) - gfc_current_ns->proc_name->attr.implicit_pure = 0; - - if (tail->expr->ts.deferred) + m = gfc_match_char (','); + if (m == MATCH_ERROR) + goto syntax; + if (m == MATCH_NO) { - saw_deferred = true; - deferred_locus = tail->expr->where; + m = gfc_match_char (')'); + if (m == MATCH_YES) + goto done; + goto syntax; } + } - /* The ALLOCATE statement had an optional typespec. Check the - constraints. */ - if (ts.type != BT_UNKNOWN) + for (;;) + { + m = gfc_match (" stat = %v", &tmp); + if (m == MATCH_ERROR) + goto syntax; + if (m == MATCH_YES) { - /* Enforce F03:C624. */ - if (!gfc_type_compatible (&tail->expr->ts, &ts)) + if (saw_stat) { - gfc_error ("Type of entity at %L is type incompatible with " - "typespec", &tail->expr->where); + gfc_error ("Redundant STAT tag found at %L ", &tmp->where); goto cleanup; } + stat = tmp; + saw_stat = true; - /* Enforce F03:C627. */ - if (ts.kind != tail->expr->ts.kind) + if (gfc_match_char (',') == MATCH_YES) + continue; + + tmp = NULL; + break; + } + + m = gfc_match (" errmsg = %v", &tmp); + if (m == MATCH_ERROR) + goto syntax; + if (m == MATCH_YES) + { + if (saw_errmsg) { - gfc_error ("Kind type parameter for entity at %L differs from " - "the kind type parameter of the typespec", - &tail->expr->where); + gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where); goto cleanup; } - } + errmsg = tmp; + saw_errmsg = true; - if (tail->expr->ts.type == BT_DERIVED) - tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived); + if (gfc_match_char (',') == MATCH_YES) + continue; - /* FIXME: disable the checking on derived types and arrays. */ - sym = tail->expr->symtree->n.sym; - b1 = !(tail->expr->ref - && (tail->expr->ref->type == REF_COMPONENT - || tail->expr->ref->type == REF_ARRAY)); - if (sym && sym->ts.type == BT_CLASS && sym->attr.class_ok) - b2 = !(CLASS_DATA (sym)->attr.allocatable - || CLASS_DATA (sym)->attr.class_pointer); - else - b2 = sym && !(sym->attr.allocatable || sym->attr.pointer - || sym->attr.proc_pointer); - b3 = sym && sym->ns && sym->ns->proc_name - && (sym->ns->proc_name->attr.allocatable - || sym->ns->proc_name->attr.pointer - || sym->ns->proc_name->attr.proc_pointer); - if (b1 && b2 && !b3) - { - gfc_error ("Allocate-object at %L is not a nonprocedure pointer " - "or an allocatable variable", &tail->expr->where); - goto cleanup; - } - - if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension) - { - gfc_error ("Shape specification for allocatable scalar at %C"); - goto cleanup; + tmp = NULL; + break; } - if (gfc_match_char (',') != MATCH_YES) break; + } -alloc_opt_list: - - m = gfc_match (" stat = %v", &tmp); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_YES) - { - /* Enforce C630. */ - if (saw_stat) - { - gfc_error ("Redundant STAT tag found at %L ", &tmp->where); - goto cleanup; - } - - stat = tmp; - tmp = NULL; - saw_stat = true; - - if (gfc_check_do_variable (stat->symtree)) - goto cleanup; - - if (gfc_match_char (',') == MATCH_YES) - goto alloc_opt_list; - } + if (m == MATCH_ERROR) + goto syntax; - m = gfc_match (" errmsg = %v", &tmp); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_YES) - { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG tag at %L", - &tmp->where) == FAILURE) - goto cleanup; + if (gfc_match (" )%t") != MATCH_YES) + goto syntax; - /* Enforce C630. */ - if (saw_errmsg) - { - gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where); - goto cleanup; - } +done: + switch (st) + { + case ST_SYNC_ALL: + new_st.op = EXEC_SYNC_ALL; + break; + case ST_SYNC_IMAGES: + new_st.op = EXEC_SYNC_IMAGES; + break; + case ST_SYNC_MEMORY: + new_st.op = EXEC_SYNC_MEMORY; + break; + default: + gcc_unreachable (); + } - errmsg = tmp; - tmp = NULL; - saw_errmsg = true; + new_st.expr1 = imageset; + new_st.expr2 = stat; + new_st.expr3 = errmsg; - if (gfc_match_char (',') == MATCH_YES) - goto alloc_opt_list; - } + return MATCH_YES; - m = gfc_match (" source = %e", &tmp); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_YES) - { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SOURCE tag at %L", - &tmp->where) == FAILURE) - goto cleanup; +syntax: + gfc_syntax_error (st); - /* Enforce C630. */ - if (saw_source) - { - gfc_error ("Redundant SOURCE tag found at %L ", &tmp->where); - goto cleanup; - } +cleanup: + gfc_free_expr (tmp); + gfc_free_expr (imageset); + gfc_free_expr (stat); + gfc_free_expr (errmsg); - /* The next 2 conditionals check C631. */ - if (ts.type != BT_UNKNOWN) - { - gfc_error ("SOURCE tag at %L conflicts with the typespec at %L", - &tmp->where, &old_locus); - goto cleanup; - } + return MATCH_ERROR; +} - if (head->next) - { - gfc_error ("SOURCE tag at %L requires only a single entity in " - "the allocation-list", &tmp->where); - goto cleanup; - } - source = tmp; - tmp = NULL; - saw_source = true; +/* Match SYNC ALL statement. */ - if (gfc_match_char (',') == MATCH_YES) - goto alloc_opt_list; - } +match +gfc_match_sync_all (void) +{ + return sync_statement (ST_SYNC_ALL); +} - m = gfc_match (" mold = %e", &tmp); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_YES) - { - if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: MOLD tag at %L", - &tmp->where) == FAILURE) - goto cleanup; - /* Check F08:C636. */ - if (saw_mold) - { - gfc_error ("Redundant MOLD tag found at %L ", &tmp->where); - goto cleanup; - } - - /* Check F08:C637. */ - if (ts.type != BT_UNKNOWN) - { - gfc_error ("MOLD tag at %L conflicts with the typespec at %L", - &tmp->where, &old_locus); - goto cleanup; - } +/* Match SYNC IMAGES statement. */ - mold = tmp; - tmp = NULL; - saw_mold = true; - mold->mold = 1; +match +gfc_match_sync_images (void) +{ + return sync_statement (ST_SYNC_IMAGES); +} - if (gfc_match_char (',') == MATCH_YES) - goto alloc_opt_list; - } - gfc_gobble_whitespace (); +/* Match SYNC MEMORY statement. */ - if (gfc_peek_char () == ')') - break; - } +match +gfc_match_sync_memory (void) +{ + return sync_statement (ST_SYNC_MEMORY); +} - if (gfc_match (" )%t") != MATCH_YES) - goto syntax; - /* Check F08:C637. */ - if (source && mold) - { - gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L", - &mold->where, &source->where); - goto cleanup; - } +/* Match a CONTINUE statement. */ - /* Check F03:C623, */ - if (saw_deferred && ts.type == BT_UNKNOWN && !source && !mold) +match +gfc_match_continue (void) +{ + if (gfc_match_eos () != MATCH_YES) { - gfc_error ("Allocate-object at %L with a deferred type parameter " - "requires either a type-spec or SOURCE tag or a MOLD tag", - &deferred_locus); - goto cleanup; + gfc_syntax_error (ST_CONTINUE); + return MATCH_ERROR; } - - new_st.op = EXEC_ALLOCATE; - new_st.expr1 = stat; - new_st.expr2 = errmsg; - if (source) - new_st.expr3 = source; - else - new_st.expr3 = mold; - new_st.ext.alloc.list = head; - new_st.ext.alloc.ts = ts; + new_st.op = EXEC_CONTINUE; return MATCH_YES; - -syntax: - gfc_syntax_error (ST_ALLOCATE); - -cleanup: - gfc_free_expr (errmsg); - gfc_free_expr (source); - gfc_free_expr (stat); - gfc_free_expr (mold); - if (tmp && tmp->expr_type) gfc_free_expr (tmp); - gfc_free_alloc_list (head); - return MATCH_ERROR; } -/* Match a NULLIFY statement. A NULLIFY statement is transformed into - a set of pointer assignments to intrinsic NULL(). */ +/* Match the (deprecated) ASSIGN statement. */ match -gfc_match_nullify (void) +gfc_match_assign (void) { - gfc_code *tail; - gfc_expr *e, *p; - match m; - - tail = NULL; - - if (gfc_match_char ('(') != MATCH_YES) - goto syntax; + gfc_expr *expr; + gfc_st_label *label; - for (;;) + if (gfc_match (" %l", &label) == MATCH_YES) { - m = gfc_match_variable (&p, 0); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - - if (gfc_check_do_variable (p->symtree)) - goto cleanup; - - /* F2008, C1242. */ - if (gfc_is_coindexed (p)) + if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE) + return MATCH_ERROR; + if (gfc_match (" to %v%t", &expr) == MATCH_YES) { - gfc_error ("Pointer object at %C shall not be conindexed"); - goto cleanup; - } + if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGN " + "statement at %C") + == FAILURE) + return MATCH_ERROR; - /* build ' => NULL() '. */ - e = gfc_get_null_expr (&gfc_current_locus); + expr->symtree->n.sym->attr.assign = 1; - /* Chain to list. */ - if (tail == NULL) - tail = &new_st; - else - { - tail->next = gfc_get_code (); - tail = tail->next; + new_st.op = EXEC_LABEL_ASSIGN; + new_st.label1 = label; + new_st.expr1 = expr; + return MATCH_YES; } - - tail->op = EXEC_POINTER_ASSIGN; - tail->expr1 = p; - tail->expr2 = e; - - if (gfc_match (" )%t") == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; } - - return MATCH_YES; - -syntax: - gfc_syntax_error (ST_NULLIFY); - -cleanup: - gfc_free_statements (new_st.next); - new_st.next = NULL; - gfc_free_expr (new_st.expr1); - new_st.expr1 = NULL; - gfc_free_expr (new_st.expr2); - new_st.expr2 = NULL; - return MATCH_ERROR; + return MATCH_NO; } -/* Match a DEALLOCATE statement. */ +/* Match the GO TO statement. As a computed GOTO statement is + matched, it is transformed into an equivalent SELECT block. No + tree is necessary, and the resulting jumps-to-jumps are + specifically optimized away by the back end. */ match -gfc_match_deallocate (void) +gfc_match_goto (void) { - gfc_alloc *head, *tail; - gfc_expr *stat, *errmsg, *tmp; - gfc_symbol *sym; + gfc_code *head, *tail; + gfc_expr *expr; + gfc_case *cp; + gfc_st_label *label; + int i; match m; - bool saw_stat, saw_errmsg, b1, b2; - - head = tail = NULL; - stat = errmsg = tmp = NULL; - saw_stat = saw_errmsg = false; - - if (gfc_match_char ('(') != MATCH_YES) - goto syntax; - for (;;) + if (gfc_match (" %l%t", &label) == MATCH_YES) { - if (head == NULL) - head = tail = gfc_get_alloc (); - else - { - tail->next = gfc_get_alloc (); - tail = tail->next; - } + if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE) + return MATCH_ERROR; - m = gfc_match_variable (&tail->expr, 0); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; + new_st.op = EXEC_GOTO; + new_st.label1 = label; + return MATCH_YES; + } - if (gfc_check_do_variable (tail->expr->symtree)) - goto cleanup; + /* The assigned GO TO statement. */ - sym = tail->expr->symtree->n.sym; + if (gfc_match_variable (&expr, 0) == MATCH_YES) + { + if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: Assigned GOTO " + "statement at %C") + == FAILURE) + return MATCH_ERROR; - if (gfc_pure (NULL) && gfc_impure_variable (sym)) - { - gfc_error ("Illegal allocate-object at %C for a PURE procedure"); - goto cleanup; - } + new_st.op = EXEC_GOTO; + new_st.expr1 = expr; - if (gfc_implicit_pure (NULL) && gfc_impure_variable (sym)) - gfc_current_ns->proc_name->attr.implicit_pure = 0; + if (gfc_match_eos () == MATCH_YES) + return MATCH_YES; - /* FIXME: disable the checking on derived types. */ - b1 = !(tail->expr->ref - && (tail->expr->ref->type == REF_COMPONENT - || tail->expr->ref->type == REF_ARRAY)); - if (sym && sym->ts.type == BT_CLASS) - b2 = !(CLASS_DATA (sym)->attr.allocatable - || CLASS_DATA (sym)->attr.class_pointer); - else - b2 = sym && !(sym->attr.allocatable || sym->attr.pointer - || sym->attr.proc_pointer); - if (b1 && b2) + /* Match label list. */ + gfc_match_char (','); + if (gfc_match_char ('(') != MATCH_YES) { - gfc_error ("Allocate-object at %C is not a nonprocedure pointer " - "or an allocatable variable"); - goto cleanup; + gfc_syntax_error (ST_GOTO); + return MATCH_ERROR; } + head = tail = NULL; - if (gfc_match_char (',') != MATCH_YES) - break; + do + { + m = gfc_match_st_label (&label); + if (m != MATCH_YES) + goto syntax; -dealloc_opt_list: + if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE) + goto cleanup; - m = gfc_match (" stat = %v", &tmp); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_YES) - { - if (saw_stat) + if (head == NULL) + head = tail = gfc_get_code (); + else { - gfc_error ("Redundant STAT tag found at %L ", &tmp->where); - gfc_free_expr (tmp); - goto cleanup; + tail->block = gfc_get_code (); + tail = tail->block; } - stat = tmp; - saw_stat = true; + tail->label1 = label; + tail->op = EXEC_GOTO; + } + while (gfc_match_char (',') == MATCH_YES); - if (gfc_check_do_variable (stat->symtree)) - goto cleanup; + if (gfc_match (")%t") != MATCH_YES) + goto syntax; - if (gfc_match_char (',') == MATCH_YES) - goto dealloc_opt_list; + if (head == NULL) + { + gfc_error ("Statement label list in GOTO at %C cannot be empty"); + goto syntax; } + new_st.block = head; - m = gfc_match (" errmsg = %v", &tmp); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_YES) - { - if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L", - &tmp->where) == FAILURE) - goto cleanup; + return MATCH_YES; + } - if (saw_errmsg) - { - gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where); - gfc_free_expr (tmp); - goto cleanup; - } + /* Last chance is a computed GO TO statement. */ + if (gfc_match_char ('(') != MATCH_YES) + { + gfc_syntax_error (ST_GOTO); + return MATCH_ERROR; + } - errmsg = tmp; - saw_errmsg = true; + head = tail = NULL; + i = 1; - if (gfc_match_char (',') == MATCH_YES) - goto dealloc_opt_list; + do + { + m = gfc_match_st_label (&label); + if (m != MATCH_YES) + goto syntax; + + if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE) + goto cleanup; + + if (head == NULL) + head = tail = gfc_get_code (); + else + { + tail->block = gfc_get_code (); + tail = tail->block; } - gfc_gobble_whitespace (); + cp = gfc_get_case (); + cp->low = cp->high = gfc_get_int_expr (gfc_default_integer_kind, + NULL, i++); - if (gfc_peek_char () == ')') - break; + tail->op = EXEC_SELECT; + tail->ext.block.case_list = cp; + + tail->next = gfc_get_code (); + tail->next->op = EXEC_GOTO; + tail->next->label1 = label; } + while (gfc_match_char (',') == MATCH_YES); - if (gfc_match (" )%t") != MATCH_YES) + if (gfc_match_char (')') != MATCH_YES) goto syntax; - new_st.op = EXEC_DEALLOCATE; - new_st.expr1 = stat; - new_st.expr2 = errmsg; - new_st.ext.alloc.list = head; + if (head == NULL) + { + gfc_error ("Statement label list in GOTO at %C cannot be empty"); + goto syntax; + } - return MATCH_YES; + /* Get the rest of the statement. */ + gfc_match_char (','); -syntax: - gfc_syntax_error (ST_DEALLOCATE); + if (gfc_match (" %e%t", &expr) != MATCH_YES) + goto syntax; -cleanup: - gfc_free_expr (errmsg); - gfc_free_expr (stat); - gfc_free_alloc_list (head); - return MATCH_ERROR; -} - - -/* Match a RETURN statement. */ - -match -gfc_match_return (void) -{ - gfc_expr *e; - match m; - gfc_compile_state s; - - e = NULL; - - if (gfc_find_state (COMP_CRITICAL) == SUCCESS) - { - gfc_error ("Image control statement RETURN at %C in CRITICAL block"); - return MATCH_ERROR; - } - - if (gfc_match_eos () == MATCH_YES) - goto done; - - if (gfc_find_state (COMP_SUBROUTINE) == FAILURE) - { - gfc_error ("Alternate RETURN statement at %C is only allowed within " - "a SUBROUTINE"); - goto cleanup; - } - - if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Alternate RETURN " + if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Computed GOTO " "at %C") == FAILURE) return MATCH_ERROR; - if (gfc_current_form == FORM_FREE) - { - /* The following are valid, so we can't require a blank after the - RETURN keyword: - return+1 - return(1) */ - char c = gfc_peek_ascii_char (); - if (ISALPHA (c) || ISDIGIT (c)) - return MATCH_NO; - } + /* At this point, a computed GOTO has been fully matched and an + equivalent SELECT statement constructed. */ - m = gfc_match (" %e%t", &e); - if (m == MATCH_YES) - goto done; - if (m == MATCH_ERROR) - goto cleanup; + new_st.op = EXEC_SELECT; + new_st.expr1 = NULL; - gfc_syntax_error (ST_RETURN); + /* Hack: For a "real" SELECT, the expression is in expr. We put + it in expr2 so we can distinguish then and produce the correct + diagnostics. */ + new_st.expr2 = expr; + new_st.block = head; + return MATCH_YES; +syntax: + gfc_syntax_error (ST_GOTO); cleanup: - gfc_free_expr (e); + gfc_free_statements (head); return MATCH_ERROR; - -done: - gfc_enclosing_unit (&s); - if (s == COMP_PROGRAM - && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in " - "main program at %C") == FAILURE) - return MATCH_ERROR; - - new_st.op = EXEC_RETURN; - new_st.expr1 = e; - - return MATCH_YES; } -/* Match the call of a type-bound procedure, if CALL%var has already been - matched and var found to be a derived-type variable. */ +/* Frees a list of gfc_alloc structures. */ -static match -match_typebound_call (gfc_symtree* varst) +void +gfc_free_alloc_list (gfc_alloc *p) { - gfc_expr* base; - match m; - - base = gfc_get_expr (); - base->expr_type = EXPR_VARIABLE; - base->symtree = varst; - base->where = gfc_current_locus; - gfc_set_sym_referenced (varst->n.sym); - - m = gfc_match_varspec (base, 0, true, true); - if (m == MATCH_NO) - gfc_error ("Expected component reference at %C"); - if (m != MATCH_YES) - return MATCH_ERROR; - - if (gfc_match_eos () != MATCH_YES) - { - gfc_error ("Junk after CALL at %C"); - return MATCH_ERROR; - } + gfc_alloc *q; - if (base->expr_type == EXPR_COMPCALL) - new_st.op = EXEC_COMPCALL; - else if (base->expr_type == EXPR_PPC) - new_st.op = EXEC_CALL_PPC; - else + for (; p; p = q) { - gfc_error ("Expected type-bound procedure or procedure pointer component " - "at %C"); - return MATCH_ERROR; + q = p->next; + gfc_free_expr (p->expr); + free (p); } - new_st.expr1 = base; - - return MATCH_YES; } -/* Match a CALL statement. The tricky part here are possible - alternate return specifiers. We handle these by having all - "subroutines" actually return an integer via a register that gives - the return number. If the call specifies alternate returns, we - generate code for a SELECT statement whose case clauses contain - GOTOs to the various labels. */ +/* Match an ALLOCATE statement. */ match -gfc_match_call (void) +gfc_match_allocate (void) { - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_actual_arglist *a, *arglist; - gfc_case *new_case; + gfc_alloc *head, *tail; + gfc_expr *stat, *errmsg, *tmp, *source, *mold; + gfc_typespec ts; gfc_symbol *sym; - gfc_symtree *st; - gfc_code *c; match m; - int i; + locus old_locus, deferred_locus; + bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3; - arglist = NULL; + head = tail = NULL; + stat = errmsg = source = mold = tmp = NULL; + saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false; - m = gfc_match ("% %n", name); - if (m == MATCH_NO) + if (gfc_match_char ('(') != MATCH_YES) goto syntax; - if (m != MATCH_YES) - return m; - - if (gfc_get_ha_sym_tree (name, &st)) - return MATCH_ERROR; - sym = st->n.sym; + /* Match an optional type-spec. */ + old_locus = gfc_current_locus; + m = match_type_spec (&ts); + if (m == MATCH_ERROR) + goto cleanup; + else if (m == MATCH_NO) + { + char name[GFC_MAX_SYMBOL_LEN + 3]; - /* If this is a variable of derived-type, it probably starts a type-bound - procedure call. */ - if ((sym->attr.flavor != FL_PROCEDURE - || gfc_is_function_return_value (sym, gfc_current_ns)) - && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)) - return match_typebound_call (st); + if (gfc_match ("%n :: ", name) == MATCH_YES) + { + gfc_error ("Error in type-spec at %L", &old_locus); + goto cleanup; + } - /* If it does not seem to be callable (include functions so that the - right association is made. They are thrown out in resolution.) - ... */ - if (!sym->attr.generic - && !sym->attr.subroutine - && !sym->attr.function) + ts.type = BT_UNKNOWN; + } + else { - if (!(sym->attr.external && !sym->attr.referenced)) + if (gfc_match (" :: ") == MATCH_YES) { - /* ...create a symbol in this scope... */ - if (sym->ns != gfc_current_ns - && gfc_get_sym_tree (name, NULL, &st, false) == 1) - return MATCH_ERROR; + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: typespec in " + "ALLOCATE at %L", &old_locus) == FAILURE) + goto cleanup; - if (sym != st->n.sym) - sym = st->n.sym; + if (ts.deferred) + { + gfc_error ("Type-spec at %L cannot contain a deferred " + "type parameter", &old_locus); + goto cleanup; + } + } + else + { + ts.type = BT_UNKNOWN; + gfc_current_locus = old_locus; } - - /* ...and then to try to make the symbol into a subroutine. */ - if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE) - return MATCH_ERROR; } - gfc_set_sym_referenced (sym); - - if (gfc_match_eos () != MATCH_YES) + for (;;) { - m = gfc_match_actual_arglist (1, &arglist); + if (head == NULL) + head = tail = gfc_get_alloc (); + else + { + tail->next = gfc_get_alloc (); + tail = tail->next; + } + + m = gfc_match_variable (&tail->expr, 0); if (m == MATCH_NO) goto syntax; if (m == MATCH_ERROR) goto cleanup; - if (gfc_match_eos () != MATCH_YES) - goto syntax; - } + if (gfc_check_do_variable (tail->expr->symtree)) + goto cleanup; - /* If any alternate return labels were found, construct a SELECT - statement that will jump to the right place. */ + if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym)) + { + gfc_error ("Bad allocate-object at %C for a PURE procedure"); + goto cleanup; + } - i = 0; - for (a = arglist; a; a = a->next) - if (a->expr == NULL) - i = 1; + if (gfc_implicit_pure (NULL) + && gfc_impure_variable (tail->expr->symtree->n.sym)) + gfc_current_ns->proc_name->attr.implicit_pure = 0; - if (i) - { - gfc_symtree *select_st; - gfc_symbol *select_sym; - char name[GFC_MAX_SYMBOL_LEN + 1]; + if (tail->expr->ts.deferred) + { + saw_deferred = true; + deferred_locus = tail->expr->where; + } - new_st.next = c = gfc_get_code (); - c->op = EXEC_SELECT; - sprintf (name, "_result_%s", sym->name); - gfc_get_ha_sym_tree (name, &select_st); /* Can't fail. */ + if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS + || gfc_find_state (COMP_CRITICAL) == SUCCESS) + { + gfc_ref *ref; + bool coarray = tail->expr->symtree->n.sym->attr.codimension; + for (ref = tail->expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + coarray = ref->u.c.component->attr.codimension; - select_sym = select_st->n.sym; - select_sym->ts.type = BT_INTEGER; - select_sym->ts.kind = gfc_default_integer_kind; - gfc_set_sym_referenced (select_sym); - c->expr1 = gfc_get_expr (); - c->expr1->expr_type = EXPR_VARIABLE; - c->expr1->symtree = select_st; - c->expr1->ts = select_sym->ts; - c->expr1->where = gfc_current_locus; + if (coarray && gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS) + { + gfc_error ("ALLOCATE of coarray at %C in DO CONCURRENT block"); + goto cleanup; + } + if (coarray && gfc_find_state (COMP_CRITICAL) == SUCCESS) + { + gfc_error ("ALLOCATE of coarray at %C in CRITICAL block"); + goto cleanup; + } + } - i = 0; - for (a = arglist; a; a = a->next) + /* The ALLOCATE statement had an optional typespec. Check the + constraints. */ + if (ts.type != BT_UNKNOWN) { - if (a->expr != NULL) - continue; + /* Enforce F03:C624. */ + if (!gfc_type_compatible (&tail->expr->ts, &ts)) + { + gfc_error ("Type of entity at %L is type incompatible with " + "typespec", &tail->expr->where); + goto cleanup; + } - if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE) - continue; + /* Enforce F03:C627. */ + if (ts.kind != tail->expr->ts.kind) + { + gfc_error ("Kind type parameter for entity at %L differs from " + "the kind type parameter of the typespec", + &tail->expr->where); + goto cleanup; + } + } - i++; + if (tail->expr->ts.type == BT_DERIVED) + tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived); - c->block = gfc_get_code (); - c = c->block; - c->op = EXEC_SELECT; + /* FIXME: disable the checking on derived types and arrays. */ + sym = tail->expr->symtree->n.sym; + b1 = !(tail->expr->ref + && (tail->expr->ref->type == REF_COMPONENT + || tail->expr->ref->type == REF_ARRAY)); + if (sym && sym->ts.type == BT_CLASS && sym->attr.class_ok) + b2 = !(CLASS_DATA (sym)->attr.allocatable + || CLASS_DATA (sym)->attr.class_pointer); + else + b2 = sym && !(sym->attr.allocatable || sym->attr.pointer + || sym->attr.proc_pointer); + b3 = sym && sym->ns && sym->ns->proc_name + && (sym->ns->proc_name->attr.allocatable + || sym->ns->proc_name->attr.pointer + || sym->ns->proc_name->attr.proc_pointer); + if (b1 && b2 && !b3) + { + gfc_error ("Allocate-object at %L is not a nonprocedure pointer " + "or an allocatable variable", &tail->expr->where); + goto cleanup; + } - new_case = gfc_get_case (); - new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i); - new_case->low = new_case->high; - c->ext.block.case_list = new_case; + if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension) + { + gfc_error ("Shape specification for allocatable scalar at %C"); + goto cleanup; + } - c->next = gfc_get_code (); - c->next->op = EXEC_GOTO; - c->next->label1 = a->label; + if (gfc_match_char (',') != MATCH_YES) + break; + +alloc_opt_list: + + m = gfc_match (" stat = %v", &tmp); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_YES) + { + /* Enforce C630. */ + if (saw_stat) + { + gfc_error ("Redundant STAT tag found at %L ", &tmp->where); + goto cleanup; + } + + stat = tmp; + tmp = NULL; + saw_stat = true; + + if (gfc_check_do_variable (stat->symtree)) + goto cleanup; + + if (gfc_match_char (',') == MATCH_YES) + goto alloc_opt_list; + } + + m = gfc_match (" errmsg = %v", &tmp); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_YES) + { + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG tag at %L", + &tmp->where) == FAILURE) + goto cleanup; + + /* Enforce C630. */ + if (saw_errmsg) + { + gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where); + goto cleanup; + } + + errmsg = tmp; + tmp = NULL; + saw_errmsg = true; + + if (gfc_match_char (',') == MATCH_YES) + goto alloc_opt_list; + } + + m = gfc_match (" source = %e", &tmp); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_YES) + { + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SOURCE tag at %L", + &tmp->where) == FAILURE) + goto cleanup; + + /* Enforce C630. */ + if (saw_source) + { + gfc_error ("Redundant SOURCE tag found at %L ", &tmp->where); + goto cleanup; + } + + /* The next 2 conditionals check C631. */ + if (ts.type != BT_UNKNOWN) + { + gfc_error ("SOURCE tag at %L conflicts with the typespec at %L", + &tmp->where, &old_locus); + goto cleanup; + } + + if (head->next) + { + gfc_error ("SOURCE tag at %L requires only a single entity in " + "the allocation-list", &tmp->where); + goto cleanup; + } + + source = tmp; + tmp = NULL; + saw_source = true; + + if (gfc_match_char (',') == MATCH_YES) + goto alloc_opt_list; } + + m = gfc_match (" mold = %e", &tmp); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_YES) + { + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: MOLD tag at %L", + &tmp->where) == FAILURE) + goto cleanup; + + /* Check F08:C636. */ + if (saw_mold) + { + gfc_error ("Redundant MOLD tag found at %L ", &tmp->where); + goto cleanup; + } + + /* Check F08:C637. */ + if (ts.type != BT_UNKNOWN) + { + gfc_error ("MOLD tag at %L conflicts with the typespec at %L", + &tmp->where, &old_locus); + goto cleanup; + } + + mold = tmp; + tmp = NULL; + saw_mold = true; + mold->mold = 1; + + if (gfc_match_char (',') == MATCH_YES) + goto alloc_opt_list; + } + + gfc_gobble_whitespace (); + + if (gfc_peek_char () == ')') + break; } - new_st.op = EXEC_CALL; - new_st.symtree = st; - new_st.ext.actual = arglist; + if (gfc_match (" )%t") != MATCH_YES) + goto syntax; + + /* Check F08:C637. */ + if (source && mold) + { + gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L", + &mold->where, &source->where); + goto cleanup; + } + + /* Check F03:C623, */ + if (saw_deferred && ts.type == BT_UNKNOWN && !source && !mold) + { + gfc_error ("Allocate-object at %L with a deferred type parameter " + "requires either a type-spec or SOURCE tag or a MOLD tag", + &deferred_locus); + goto cleanup; + } + + new_st.op = EXEC_ALLOCATE; + new_st.expr1 = stat; + new_st.expr2 = errmsg; + if (source) + new_st.expr3 = source; + else + new_st.expr3 = mold; + new_st.ext.alloc.list = head; + new_st.ext.alloc.ts = ts; return MATCH_YES; syntax: - gfc_syntax_error (ST_CALL); + gfc_syntax_error (ST_ALLOCATE); cleanup: - gfc_free_actual_arglist (arglist); + gfc_free_expr (errmsg); + gfc_free_expr (source); + gfc_free_expr (stat); + gfc_free_expr (mold); + if (tmp && tmp->expr_type) gfc_free_expr (tmp); + gfc_free_alloc_list (head); return MATCH_ERROR; } -/* Given a name, return a pointer to the common head structure, - creating it if it does not exist. If FROM_MODULE is nonzero, we - mangle the name so that it doesn't interfere with commons defined - in the using namespace. - TODO: Add to global symbol tree. */ +/* Match a NULLIFY statement. A NULLIFY statement is transformed into + a set of pointer assignments to intrinsic NULL(). */ -gfc_common_head * -gfc_get_common (const char *name, int from_module) +match +gfc_match_nullify (void) { - gfc_symtree *st; - static int serial = 0; - char mangled_name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_code *tail; + gfc_expr *e, *p; + match m; - if (from_module) - { - /* A use associated common block is only needed to correctly layout - the variables it contains. */ - snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name); - st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name); - } - else - { - st = gfc_find_symtree (gfc_current_ns->common_root, name); + tail = NULL; - if (st == NULL) - st = gfc_new_symtree (&gfc_current_ns->common_root, name); - } + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; - if (st->n.common == NULL) + for (;;) { - st->n.common = gfc_get_common_head (); - st->n.common->where = gfc_current_locus; - strcpy (st->n.common->name, name); + m = gfc_match_variable (&p, 0); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + if (gfc_check_do_variable (p->symtree)) + goto cleanup; + + /* F2008, C1242. */ + if (gfc_is_coindexed (p)) + { + gfc_error ("Pointer object at %C shall not be conindexed"); + goto cleanup; + } + + /* build ' => NULL() '. */ + e = gfc_get_null_expr (&gfc_current_locus); + + /* Chain to list. */ + if (tail == NULL) + tail = &new_st; + else + { + tail->next = gfc_get_code (); + tail = tail->next; + } + + tail->op = EXEC_POINTER_ASSIGN; + tail->expr1 = p; + tail->expr2 = e; + + if (gfc_match (" )%t") == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; } - return st->n.common; + return MATCH_YES; + +syntax: + gfc_syntax_error (ST_NULLIFY); + +cleanup: + gfc_free_statements (new_st.next); + new_st.next = NULL; + gfc_free_expr (new_st.expr1); + new_st.expr1 = NULL; + gfc_free_expr (new_st.expr2); + new_st.expr2 = NULL; + return MATCH_ERROR; } -/* Match a common block name. */ +/* Match a DEALLOCATE statement. */ -match match_common_name (char *name) +match +gfc_match_deallocate (void) { + gfc_alloc *head, *tail; + gfc_expr *stat, *errmsg, *tmp; + gfc_symbol *sym; match m; + bool saw_stat, saw_errmsg, b1, b2; - if (gfc_match_char ('/') == MATCH_NO) - { - name[0] = '\0'; - return MATCH_YES; - } + head = tail = NULL; + stat = errmsg = tmp = NULL; + saw_stat = saw_errmsg = false; - if (gfc_match_char ('/') == MATCH_YES) + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + for (;;) { - name[0] = '\0'; - return MATCH_YES; + if (head == NULL) + head = tail = gfc_get_alloc (); + else + { + tail->next = gfc_get_alloc (); + tail = tail->next; + } + + m = gfc_match_variable (&tail->expr, 0); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; + + if (gfc_check_do_variable (tail->expr->symtree)) + goto cleanup; + + sym = tail->expr->symtree->n.sym; + + if (gfc_pure (NULL) && gfc_impure_variable (sym)) + { + gfc_error ("Illegal allocate-object at %C for a PURE procedure"); + goto cleanup; + } + + if (gfc_implicit_pure (NULL) && gfc_impure_variable (sym)) + gfc_current_ns->proc_name->attr.implicit_pure = 0; + + if (gfc_is_coarray (tail->expr) + && gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS) + { + gfc_error ("DEALLOCATE of coarray at %C in DO CONCURRENT block"); + goto cleanup; + } + + if (gfc_is_coarray (tail->expr) + && gfc_find_state (COMP_CRITICAL) == SUCCESS) + { + gfc_error ("DEALLOCATE of coarray at %C in CRITICAL block"); + goto cleanup; + } + + /* FIXME: disable the checking on derived types. */ + b1 = !(tail->expr->ref + && (tail->expr->ref->type == REF_COMPONENT + || tail->expr->ref->type == REF_ARRAY)); + if (sym && sym->ts.type == BT_CLASS) + b2 = !(CLASS_DATA (sym)->attr.allocatable + || CLASS_DATA (sym)->attr.class_pointer); + else + b2 = sym && !(sym->attr.allocatable || sym->attr.pointer + || sym->attr.proc_pointer); + if (b1 && b2) + { + gfc_error ("Allocate-object at %C is not a nonprocedure pointer " + "or an allocatable variable"); + goto cleanup; + } + + if (gfc_match_char (',') != MATCH_YES) + break; + +dealloc_opt_list: + + m = gfc_match (" stat = %v", &tmp); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_YES) + { + if (saw_stat) + { + gfc_error ("Redundant STAT tag found at %L ", &tmp->where); + gfc_free_expr (tmp); + goto cleanup; + } + + stat = tmp; + saw_stat = true; + + if (gfc_check_do_variable (stat->symtree)) + goto cleanup; + + if (gfc_match_char (',') == MATCH_YES) + goto dealloc_opt_list; + } + + m = gfc_match (" errmsg = %v", &tmp); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_YES) + { + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L", + &tmp->where) == FAILURE) + goto cleanup; + + if (saw_errmsg) + { + gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where); + gfc_free_expr (tmp); + goto cleanup; + } + + errmsg = tmp; + saw_errmsg = true; + + if (gfc_match_char (',') == MATCH_YES) + goto dealloc_opt_list; + } + + gfc_gobble_whitespace (); + + if (gfc_peek_char () == ')') + break; } - m = gfc_match_name (name); + if (gfc_match (" )%t") != MATCH_YES) + goto syntax; + + new_st.op = EXEC_DEALLOCATE; + new_st.expr1 = stat; + new_st.expr2 = errmsg; + new_st.ext.alloc.list = head; + + return MATCH_YES; - if (m == MATCH_ERROR) - return MATCH_ERROR; - if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES) - return MATCH_YES; +syntax: + gfc_syntax_error (ST_DEALLOCATE); - gfc_error ("Syntax error in common block name at %C"); +cleanup: + gfc_free_expr (errmsg); + gfc_free_expr (stat); + gfc_free_alloc_list (head); return MATCH_ERROR; } -/* Match a COMMON statement. */ +/* Match a RETURN statement. */ match -gfc_match_common (void) +gfc_match_return (void) { - gfc_symbol *sym, **head, *tail, *other, *old_blank_common; - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_common_head *t; - gfc_array_spec *as; - gfc_equiv *e1, *e2; + gfc_expr *e; match m; - gfc_gsymbol *gsym; + gfc_compile_state s; - old_blank_common = gfc_current_ns->blank_common.head; - if (old_blank_common) + e = NULL; + + if (gfc_find_state (COMP_CRITICAL) == SUCCESS) { - while (old_blank_common->common_next) - old_blank_common = old_blank_common->common_next; + gfc_error ("Image control statement RETURN at %C in CRITICAL block"); + return MATCH_ERROR; } - as = NULL; - - for (;;) + if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS) { - m = match_common_name (name); - if (m == MATCH_ERROR) - goto cleanup; - - gsym = gfc_get_gsymbol (name); - if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON) - { - gfc_error ("Symbol '%s' at %C is already an external symbol that " - "is not COMMON", name); - goto cleanup; - } - - if (gsym->type == GSYM_UNKNOWN) - { - gsym->type = GSYM_COMMON; - gsym->where = gfc_current_locus; - gsym->defined = 1; - } - - gsym->used = 1; - - if (name[0] == '\0') - { - t = &gfc_current_ns->blank_common; - if (t->head == NULL) - t->where = gfc_current_locus; - } - else - { - t = gfc_get_common (name, 0); - } - head = &t->head; - - if (*head == NULL) - tail = NULL; - else - { - tail = *head; - while (tail->common_next) - tail = tail->common_next; - } - - /* Grab the list of symbols. */ - for (;;) - { - m = gfc_match_symbol (&sym, 0); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - - /* Store a ref to the common block for error checking. */ - sym->common_block = t; - - /* See if we know the current common block is bind(c), and if - so, then see if we can check if the symbol is (which it'll - need to be). This can happen if the bind(c) attr stmt was - applied to the common block, and the variable(s) already - defined, before declaring the common block. */ - if (t->is_bind_c == 1) - { - if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1) - { - /* If we find an error, just print it and continue, - cause it's just semantic, and we can see if there - are more errors. */ - gfc_error_now ("Variable '%s' at %L in common block '%s' " - "at %C must be declared with a C " - "interoperable kind since common block " - "'%s' is bind(c)", - sym->name, &(sym->declared_at), t->name, - t->name); - } - - if (sym->attr.is_bind_c == 1) - gfc_error_now ("Variable '%s' in common block " - "'%s' at %C can not be bind(c) since " - "it is not global", sym->name, t->name); - } - - if (sym->attr.in_common) - { - gfc_error ("Symbol '%s' at %C is already in a COMMON block", - sym->name); - goto cleanup; - } - - if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL) - || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA) - { - if (gfc_notify_std (GFC_STD_GNU, "Initialized symbol '%s' at %C " - "can only be COMMON in " - "BLOCK DATA", sym->name) - == FAILURE) - goto cleanup; - } + gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block"); + return MATCH_ERROR; + } - if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE) - goto cleanup; + if (gfc_match_eos () == MATCH_YES) + goto done; - if (tail != NULL) - tail->common_next = sym; - else - *head = sym; + if (gfc_find_state (COMP_SUBROUTINE) == FAILURE) + { + gfc_error ("Alternate RETURN statement at %C is only allowed within " + "a SUBROUTINE"); + goto cleanup; + } - tail = sym; + if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Alternate RETURN " + "at %C") == FAILURE) + return MATCH_ERROR; - /* Deal with an optional array specification after the - symbol name. */ - m = gfc_match_array_spec (&as, true, true); - if (m == MATCH_ERROR) - goto cleanup; + if (gfc_current_form == FORM_FREE) + { + /* The following are valid, so we can't require a blank after the + RETURN keyword: + return+1 + return(1) */ + char c = gfc_peek_ascii_char (); + if (ISALPHA (c) || ISDIGIT (c)) + return MATCH_NO; + } - if (m == MATCH_YES) - { - if (as->type != AS_EXPLICIT) - { - gfc_error ("Array specification for symbol '%s' in COMMON " - "at %C must be explicit", sym->name); - goto cleanup; - } + m = gfc_match (" %e%t", &e); + if (m == MATCH_YES) + goto done; + if (m == MATCH_ERROR) + goto cleanup; - if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE) - goto cleanup; + gfc_syntax_error (ST_RETURN); - if (sym->attr.pointer) - { - gfc_error ("Symbol '%s' in COMMON at %C cannot be a " - "POINTER array", sym->name); - goto cleanup; - } +cleanup: + gfc_free_expr (e); + return MATCH_ERROR; - sym->as = as; - as = NULL; +done: + gfc_enclosing_unit (&s); + if (s == COMP_PROGRAM + && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in " + "main program at %C") == FAILURE) + return MATCH_ERROR; - } + new_st.op = EXEC_RETURN; + new_st.expr1 = e; - sym->common_head = t; + return MATCH_YES; +} - /* Check to see if the symbol is already in an equivalence group. - If it is, set the other members as being in common. */ - if (sym->attr.in_equivalence) - { - for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next) - { - for (e2 = e1; e2; e2 = e2->eq) - if (e2->expr->symtree->n.sym == sym) - goto equiv_found; - continue; +/* Match the call of a type-bound procedure, if CALL%var has already been + matched and var found to be a derived-type variable. */ - equiv_found: +static match +match_typebound_call (gfc_symtree* varst) +{ + gfc_expr* base; + match m; - for (e2 = e1; e2; e2 = e2->eq) - { - other = e2->expr->symtree->n.sym; - if (other->common_head - && other->common_head != sym->common_head) - { - gfc_error ("Symbol '%s', in COMMON block '%s' at " - "%C is being indirectly equivalenced to " - "another COMMON block '%s'", - sym->name, sym->common_head->name, - other->common_head->name); - goto cleanup; - } - other->attr.in_common = 1; - other->common_head = t; - } - } - } + base = gfc_get_expr (); + base->expr_type = EXPR_VARIABLE; + base->symtree = varst; + base->where = gfc_current_locus; + gfc_set_sym_referenced (varst->n.sym); + + m = gfc_match_varspec (base, 0, true, true); + if (m == MATCH_NO) + gfc_error ("Expected component reference at %C"); + if (m != MATCH_YES) + return MATCH_ERROR; + if (gfc_match_eos () != MATCH_YES) + { + gfc_error ("Junk after CALL at %C"); + return MATCH_ERROR; + } - gfc_gobble_whitespace (); - if (gfc_match_eos () == MATCH_YES) - goto done; - if (gfc_peek_ascii_char () == '/') - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - gfc_gobble_whitespace (); - if (gfc_peek_ascii_char () == '/') - break; - } + if (base->expr_type == EXPR_COMPCALL) + new_st.op = EXEC_COMPCALL; + else if (base->expr_type == EXPR_PPC) + new_st.op = EXEC_CALL_PPC; + else + { + gfc_error ("Expected type-bound procedure or procedure pointer component " + "at %C"); + return MATCH_ERROR; } + new_st.expr1 = base; -done: return MATCH_YES; - -syntax: - gfc_syntax_error (ST_COMMON); - -cleanup: - if (old_blank_common) - old_blank_common->common_next = NULL; - else - gfc_current_ns->blank_common.head = NULL; - gfc_free_array_spec (as); - return MATCH_ERROR; } -/* Match a BLOCK DATA program unit. */ +/* Match a CALL statement. The tricky part here are possible + alternate return specifiers. We handle these by having all + "subroutines" actually return an integer via a register that gives + the return number. If the call specifies alternate returns, we + generate code for a SELECT statement whose case clauses contain + GOTOs to the various labels. */ match -gfc_match_block_data (void) +gfc_match_call (void) { char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_actual_arglist *a, *arglist; + gfc_case *new_case; gfc_symbol *sym; + gfc_symtree *st; + gfc_code *c; match m; + int i; - if (gfc_match_eos () == MATCH_YES) - { - gfc_new_block = NULL; - return MATCH_YES; - } + arglist = NULL; - m = gfc_match ("% %n%t", name); + m = gfc_match ("% %n", name); + if (m == MATCH_NO) + goto syntax; if (m != MATCH_YES) - return MATCH_ERROR; + return m; - if (gfc_get_symbol (name, NULL, &sym)) + if (gfc_get_ha_sym_tree (name, &st)) return MATCH_ERROR; - if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE) - return MATCH_ERROR; + sym = st->n.sym; - gfc_new_block = sym; + /* If this is a variable of derived-type, it probably starts a type-bound + procedure call. */ + if ((sym->attr.flavor != FL_PROCEDURE + || gfc_is_function_return_value (sym, gfc_current_ns)) + && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)) + return match_typebound_call (st); - return MATCH_YES; -} + /* If it does not seem to be callable (include functions so that the + right association is made. They are thrown out in resolution.) + ... */ + if (!sym->attr.generic + && !sym->attr.subroutine + && !sym->attr.function) + { + if (!(sym->attr.external && !sym->attr.referenced)) + { + /* ...create a symbol in this scope... */ + if (sym->ns != gfc_current_ns + && gfc_get_sym_tree (name, NULL, &st, false) == 1) + return MATCH_ERROR; + if (sym != st->n.sym) + sym = st->n.sym; + } -/* Free a namelist structure. */ + /* ...and then to try to make the symbol into a subroutine. */ + if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE) + return MATCH_ERROR; + } -void -gfc_free_namelist (gfc_namelist *name) -{ - gfc_namelist *n; + gfc_set_sym_referenced (sym); - for (; name; name = n) + if (gfc_match_eos () != MATCH_YES) { - n = name->next; - free (name); + m = gfc_match_actual_arglist (1, &arglist); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_eos () != MATCH_YES) + goto syntax; } -} + /* If any alternate return labels were found, construct a SELECT + statement that will jump to the right place. */ -/* Match a NAMELIST statement. */ + i = 0; + for (a = arglist; a; a = a->next) + if (a->expr == NULL) + i = 1; -match -gfc_match_namelist (void) -{ - gfc_symbol *group_name, *sym; - gfc_namelist *nl; - match m, m2; + if (i) + { + gfc_symtree *select_st; + gfc_symbol *select_sym; + char name[GFC_MAX_SYMBOL_LEN + 1]; - m = gfc_match (" / %s /", &group_name); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto error; + new_st.next = c = gfc_get_code (); + c->op = EXEC_SELECT; + sprintf (name, "_result_%s", sym->name); + gfc_get_ha_sym_tree (name, &select_st); /* Can't fail. */ - for (;;) - { - if (group_name->ts.type != BT_UNKNOWN) + select_sym = select_st->n.sym; + select_sym->ts.type = BT_INTEGER; + select_sym->ts.kind = gfc_default_integer_kind; + gfc_set_sym_referenced (select_sym); + c->expr1 = gfc_get_expr (); + c->expr1->expr_type = EXPR_VARIABLE; + c->expr1->symtree = select_st; + c->expr1->ts = select_sym->ts; + c->expr1->where = gfc_current_locus; + + i = 0; + for (a = arglist; a; a = a->next) { - gfc_error ("Namelist group name '%s' at %C already has a basic " - "type of %s", group_name->name, - gfc_typename (&group_name->ts)); - return MATCH_ERROR; - } + if (a->expr != NULL) + continue; - if (group_name->attr.flavor == FL_NAMELIST - && group_name->attr.use_assoc - && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' " - "at %C already is USE associated and can" - "not be respecified.", group_name->name) - == FAILURE) - return MATCH_ERROR; + if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE) + continue; - if (group_name->attr.flavor != FL_NAMELIST - && gfc_add_flavor (&group_name->attr, FL_NAMELIST, - group_name->name, NULL) == FAILURE) - return MATCH_ERROR; + i++; - for (;;) - { - m = gfc_match_symbol (&sym, 1); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto error; + c->block = gfc_get_code (); + c = c->block; + c->op = EXEC_SELECT; - if (sym->attr.in_namelist == 0 - && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE) - goto error; + new_case = gfc_get_case (); + new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i); + new_case->low = new_case->high; + c->ext.block.case_list = new_case; - /* Use gfc_error_check here, rather than goto error, so that - these are the only errors for the next two lines. */ - if (sym->as && sym->as->type == AS_ASSUMED_SIZE) - { - gfc_error ("Assumed size array '%s' in namelist '%s' at " - "%C is not allowed", sym->name, group_name->name); - gfc_error_check (); - } + c->next = gfc_get_code (); + c->next->op = EXEC_GOTO; + c->next->label1 = a->label; + } + } - nl = gfc_get_namelist (); - nl->sym = sym; - sym->refs++; + new_st.op = EXEC_CALL; + new_st.symtree = st; + new_st.ext.actual = arglist; - if (group_name->namelist == NULL) - group_name->namelist = group_name->namelist_tail = nl; - else - { - group_name->namelist_tail->next = nl; - group_name->namelist_tail = nl; - } + return MATCH_YES; - if (gfc_match_eos () == MATCH_YES) - goto done; +syntax: + gfc_syntax_error (ST_CALL); - m = gfc_match_char (','); +cleanup: + gfc_free_actual_arglist (arglist); + return MATCH_ERROR; +} - if (gfc_match_char ('/') == MATCH_YES) - { - m2 = gfc_match (" %s /", &group_name); - if (m2 == MATCH_YES) - break; - if (m2 == MATCH_ERROR) - goto error; - goto syntax; - } - if (m != MATCH_YES) - goto syntax; - } +/* Given a name, return a pointer to the common head structure, + creating it if it does not exist. If FROM_MODULE is nonzero, we + mangle the name so that it doesn't interfere with commons defined + in the using namespace. + TODO: Add to global symbol tree. */ + +gfc_common_head * +gfc_get_common (const char *name, int from_module) +{ + gfc_symtree *st; + static int serial = 0; + char mangled_name[GFC_MAX_SYMBOL_LEN + 1]; + + if (from_module) + { + /* A use associated common block is only needed to correctly layout + the variables it contains. */ + snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name); + st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name); } + else + { + st = gfc_find_symtree (gfc_current_ns->common_root, name); -done: - return MATCH_YES; + if (st == NULL) + st = gfc_new_symtree (&gfc_current_ns->common_root, name); + } -syntax: - gfc_syntax_error (ST_NAMELIST); + if (st->n.common == NULL) + { + st->n.common = gfc_get_common_head (); + st->n.common->where = gfc_current_locus; + strcpy (st->n.common->name, name); + } -error: - return MATCH_ERROR; + return st->n.common; } -/* Match a MODULE statement. */ +/* Match a common block name. */ -match -gfc_match_module (void) +match match_common_name (char *name) { match m; - m = gfc_match (" %s%t", &gfc_new_block); - if (m != MATCH_YES) - return m; - - if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE, - gfc_new_block->name, NULL) == FAILURE) - return MATCH_ERROR; - - return MATCH_YES; -} - - -/* Free equivalence sets and lists. Recursively is the easiest way to - do this. */ + if (gfc_match_char ('/') == MATCH_NO) + { + name[0] = '\0'; + return MATCH_YES; + } -void -gfc_free_equiv_until (gfc_equiv *eq, gfc_equiv *stop) -{ - if (eq == stop) - return; + if (gfc_match_char ('/') == MATCH_YES) + { + name[0] = '\0'; + return MATCH_YES; + } - gfc_free_equiv (eq->eq); - gfc_free_equiv_until (eq->next, stop); - gfc_free_expr (eq->expr); - free (eq); -} + m = gfc_match_name (name); + if (m == MATCH_ERROR) + return MATCH_ERROR; + if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES) + return MATCH_YES; -void -gfc_free_equiv (gfc_equiv *eq) -{ - gfc_free_equiv_until (eq, NULL); + gfc_error ("Syntax error in common block name at %C"); + return MATCH_ERROR; } -/* Match an EQUIVALENCE statement. */ +/* Match a COMMON statement. */ match -gfc_match_equivalence (void) +gfc_match_common (void) { - gfc_equiv *eq, *set, *tail; - gfc_ref *ref; - gfc_symbol *sym; + gfc_symbol *sym, **head, *tail, *other, *old_blank_common; + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_common_head *t; + gfc_array_spec *as; + gfc_equiv *e1, *e2; match m; - gfc_common_head *common_head = NULL; - bool common_flag; - int cnt; + gfc_gsymbol *gsym; - tail = NULL; + old_blank_common = gfc_current_ns->blank_common.head; + if (old_blank_common) + { + while (old_blank_common->common_next) + old_blank_common = old_blank_common->common_next; + } + + as = NULL; for (;;) { - eq = gfc_get_equiv (); - if (tail == NULL) - tail = eq; + m = match_common_name (name); + if (m == MATCH_ERROR) + goto cleanup; - eq->next = gfc_current_ns->equiv; - gfc_current_ns->equiv = eq; + gsym = gfc_get_gsymbol (name); + if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON) + { + gfc_error ("Symbol '%s' at %C is already an external symbol that " + "is not COMMON", name); + goto cleanup; + } - if (gfc_match_char ('(') != MATCH_YES) - goto syntax; + if (gsym->type == GSYM_UNKNOWN) + { + gsym->type = GSYM_COMMON; + gsym->where = gfc_current_locus; + gsym->defined = 1; + } - set = eq; - common_flag = FALSE; - cnt = 0; + gsym->used = 1; + + if (name[0] == '\0') + { + t = &gfc_current_ns->blank_common; + if (t->head == NULL) + t->where = gfc_current_locus; + } + else + { + t = gfc_get_common (name, 0); + } + head = &t->head; + + if (*head == NULL) + tail = NULL; + else + { + tail = *head; + while (tail->common_next) + tail = tail->common_next; + } + /* Grab the list of symbols. */ for (;;) { - m = gfc_match_equiv_variable (&set->expr); + m = gfc_match_symbol (&sym, 0); if (m == MATCH_ERROR) goto cleanup; if (m == MATCH_NO) goto syntax; - /* count the number of objects. */ - cnt++; - - if (gfc_match_char ('%') == MATCH_YES) + /* Store a ref to the common block for error checking. */ + sym->common_block = t; + + /* See if we know the current common block is bind(c), and if + so, then see if we can check if the symbol is (which it'll + need to be). This can happen if the bind(c) attr stmt was + applied to the common block, and the variable(s) already + defined, before declaring the common block. */ + if (t->is_bind_c == 1) + { + if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1) + { + /* If we find an error, just print it and continue, + cause it's just semantic, and we can see if there + are more errors. */ + gfc_error_now ("Variable '%s' at %L in common block '%s' " + "at %C must be declared with a C " + "interoperable kind since common block " + "'%s' is bind(c)", + sym->name, &(sym->declared_at), t->name, + t->name); + } + + if (sym->attr.is_bind_c == 1) + gfc_error_now ("Variable '%s' in common block " + "'%s' at %C can not be bind(c) since " + "it is not global", sym->name, t->name); + } + + if (sym->attr.in_common) { - gfc_error ("Derived type component %C is not a " - "permitted EQUIVALENCE member"); + gfc_error ("Symbol '%s' at %C is already in a COMMON block", + sym->name); goto cleanup; } - for (ref = set->expr->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) - { - gfc_error ("Array reference in EQUIVALENCE at %C cannot " - "be an array section"); - goto cleanup; - } - - sym = set->expr->symtree->n.sym; - - if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE) - goto cleanup; - - if (sym->attr.in_common) + if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL) + || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA) { - common_flag = TRUE; - common_head = sym->common_head; - } - - if (gfc_match_char (')') == MATCH_YES) - break; - - if (gfc_match_char (',') != MATCH_YES) - goto syntax; - - set->eq = gfc_get_equiv (); - set = set->eq; - } - - if (cnt < 2) - { - gfc_error ("EQUIVALENCE at %C requires two or more objects"); - goto cleanup; - } - - /* If one of the members of an equivalence is in common, then - mark them all as being in common. Before doing this, check - that members of the equivalence group are not in different - common blocks. */ - if (common_flag) - for (set = eq; set; set = set->eq) - { - sym = set->expr->symtree->n.sym; - if (sym->common_head && sym->common_head != common_head) - { - gfc_error ("Attempt to indirectly overlap COMMON " - "blocks %s and %s by EQUIVALENCE at %C", - sym->common_head->name, common_head->name); + if (gfc_notify_std (GFC_STD_GNU, "Initialized symbol '%s' at %C " + "can only be COMMON in " + "BLOCK DATA", sym->name) + == FAILURE) goto cleanup; - } - sym->attr.in_common = 1; - sym->common_head = common_head; - } - - if (gfc_match_eos () == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - { - gfc_error ("Expecting a comma in EQUIVALENCE at %C"); - goto cleanup; - } - } - - return MATCH_YES; + } -syntax: - gfc_syntax_error (ST_EQUIVALENCE); + if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE) + goto cleanup; -cleanup: - eq = tail->next; - tail->next = NULL; + if (tail != NULL) + tail->common_next = sym; + else + *head = sym; - gfc_free_equiv (gfc_current_ns->equiv); - gfc_current_ns->equiv = eq; + tail = sym; - return MATCH_ERROR; -} + /* Deal with an optional array specification after the + symbol name. */ + m = gfc_match_array_spec (&as, true, true); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_YES) + { + if (as->type != AS_EXPLICIT) + { + gfc_error ("Array specification for symbol '%s' in COMMON " + "at %C must be explicit", sym->name); + goto cleanup; + } -/* Check that a statement function is not recursive. This is done by looking - for the statement function symbol(sym) by looking recursively through its - expression(e). If a reference to sym is found, true is returned. - 12.5.4 requires that any variable of function that is implicitly typed - shall have that type confirmed by any subsequent type declaration. The - implicit typing is conveniently done here. */ -static bool -recursive_stmt_fcn (gfc_expr *, gfc_symbol *); + if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE) + goto cleanup; -static bool -check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED) -{ + if (sym->attr.pointer) + { + gfc_error ("Symbol '%s' in COMMON at %C cannot be a " + "POINTER array", sym->name); + goto cleanup; + } - if (e == NULL) - return false; + sym->as = as; + as = NULL; - switch (e->expr_type) - { - case EXPR_FUNCTION: - if (e->symtree == NULL) - return false; + } - /* Check the name before testing for nested recursion! */ - if (sym->name == e->symtree->n.sym->name) - return true; + sym->common_head = t; - /* Catch recursion via other statement functions. */ - if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION - && e->symtree->n.sym->value - && recursive_stmt_fcn (e->symtree->n.sym->value, sym)) - return true; + /* Check to see if the symbol is already in an equivalence group. + If it is, set the other members as being in common. */ + if (sym->attr.in_equivalence) + { + for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next) + { + for (e2 = e1; e2; e2 = e2->eq) + if (e2->expr->symtree->n.sym == sym) + goto equiv_found; - if (e->symtree->n.sym->ts.type == BT_UNKNOWN) - gfc_set_default_type (e->symtree->n.sym, 0, NULL); + continue; - break; + equiv_found: - case EXPR_VARIABLE: - if (e->symtree && sym->name == e->symtree->n.sym->name) - return true; + for (e2 = e1; e2; e2 = e2->eq) + { + other = e2->expr->symtree->n.sym; + if (other->common_head + && other->common_head != sym->common_head) + { + gfc_error ("Symbol '%s', in COMMON block '%s' at " + "%C is being indirectly equivalenced to " + "another COMMON block '%s'", + sym->name, sym->common_head->name, + other->common_head->name); + goto cleanup; + } + other->attr.in_common = 1; + other->common_head = t; + } + } + } - if (e->symtree->n.sym->ts.type == BT_UNKNOWN) - gfc_set_default_type (e->symtree->n.sym, 0, NULL); - break; - default: - break; + gfc_gobble_whitespace (); + if (gfc_match_eos () == MATCH_YES) + goto done; + if (gfc_peek_ascii_char () == '/') + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; + gfc_gobble_whitespace (); + if (gfc_peek_ascii_char () == '/') + break; + } } - return false; -} +done: + return MATCH_YES; +syntax: + gfc_syntax_error (ST_COMMON); -static bool -recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym) -{ - return gfc_traverse_expr (e, sym, check_stmt_fcn, 0); +cleanup: + if (old_blank_common) + old_blank_common->common_next = NULL; + else + gfc_current_ns->blank_common.head = NULL; + gfc_free_array_spec (as); + return MATCH_ERROR; } -/* Match a statement function declaration. It is so easy to match - non-statement function statements with a MATCH_ERROR as opposed to - MATCH_NO that we suppress error message in most cases. */ +/* Match a BLOCK DATA program unit. */ match -gfc_match_st_function (void) +gfc_match_block_data (void) { - gfc_error_buf old_error; + char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_symbol *sym; - gfc_expr *expr; match m; - m = gfc_match_symbol (&sym, 0); + if (gfc_match_eos () == MATCH_YES) + { + gfc_new_block = NULL; + return MATCH_YES; + } + + m = gfc_match ("% %n%t", name); if (m != MATCH_YES) - return m; + return MATCH_ERROR; - gfc_push_error (&old_error); + if (gfc_get_symbol (name, NULL, &sym)) + return MATCH_ERROR; - if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, - sym->name, NULL) == FAILURE) - goto undo_error; + if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE) + return MATCH_ERROR; - if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES) - goto undo_error; + gfc_new_block = sym; - m = gfc_match (" = %e%t", &expr); - if (m == MATCH_NO) - goto undo_error; + return MATCH_YES; +} - gfc_free_error (&old_error); - if (m == MATCH_ERROR) - return m; - if (recursive_stmt_fcn (expr, sym)) - { - gfc_error ("Statement function at %L is recursive", &expr->where); - return MATCH_ERROR; - } +/* Free a namelist structure. */ - sym->value = expr; +void +gfc_free_namelist (gfc_namelist *name) +{ + gfc_namelist *n; - if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: " - "Statement function at %C") == FAILURE) - return MATCH_ERROR; + for (; name; name = n) + { + n = name->next; + free (name); + } +} - return MATCH_YES; -undo_error: - gfc_pop_error (&old_error); - return MATCH_NO; -} +/* Match a NAMELIST statement. */ +match +gfc_match_namelist (void) +{ + gfc_symbol *group_name, *sym; + gfc_namelist *nl; + match m, m2; -/***************** SELECT CASE subroutines ******************/ + m = gfc_match (" / %s /", &group_name); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto error; -/* Free a single case structure. */ + for (;;) + { + if (group_name->ts.type != BT_UNKNOWN) + { + gfc_error ("Namelist group name '%s' at %C already has a basic " + "type of %s", group_name->name, + gfc_typename (&group_name->ts)); + return MATCH_ERROR; + } -static void -free_case (gfc_case *p) -{ - if (p->low == p->high) - p->high = NULL; - gfc_free_expr (p->low); - gfc_free_expr (p->high); - free (p); -} + if (group_name->attr.flavor == FL_NAMELIST + && group_name->attr.use_assoc + && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' " + "at %C already is USE associated and can" + "not be respecified.", group_name->name) + == FAILURE) + return MATCH_ERROR; + if (group_name->attr.flavor != FL_NAMELIST + && gfc_add_flavor (&group_name->attr, FL_NAMELIST, + group_name->name, NULL) == FAILURE) + return MATCH_ERROR; -/* Free a list of case structures. */ + for (;;) + { + m = gfc_match_symbol (&sym, 1); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto error; -void -gfc_free_case_list (gfc_case *p) -{ - gfc_case *q; + if (sym->attr.in_namelist == 0 + && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE) + goto error; - for (; p; p = q) - { - q = p->next; - free_case (p); - } -} + /* Use gfc_error_check here, rather than goto error, so that + these are the only errors for the next two lines. */ + if (sym->as && sym->as->type == AS_ASSUMED_SIZE) + { + gfc_error ("Assumed size array '%s' in namelist '%s' at " + "%C is not allowed", sym->name, group_name->name); + gfc_error_check (); + } + nl = gfc_get_namelist (); + nl->sym = sym; + sym->refs++; -/* Match a single case selector. */ + if (group_name->namelist == NULL) + group_name->namelist = group_name->namelist_tail = nl; + else + { + group_name->namelist_tail->next = nl; + group_name->namelist_tail = nl; + } -static match -match_case_selector (gfc_case **cp) -{ - gfc_case *c; - match m; + if (gfc_match_eos () == MATCH_YES) + goto done; - c = gfc_get_case (); - c->where = gfc_current_locus; + m = gfc_match_char (','); - if (gfc_match_char (':') == MATCH_YES) - { - m = gfc_match_init_expr (&c->high); - if (m == MATCH_NO) - goto need_expr; - if (m == MATCH_ERROR) - goto cleanup; - } - else - { - m = gfc_match_init_expr (&c->low); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto need_expr; + if (gfc_match_char ('/') == MATCH_YES) + { + m2 = gfc_match (" %s /", &group_name); + if (m2 == MATCH_YES) + break; + if (m2 == MATCH_ERROR) + goto error; + goto syntax; + } - /* If we're not looking at a ':' now, make a range out of a single - target. Else get the upper bound for the case range. */ - if (gfc_match_char (':') != MATCH_YES) - c->high = c->low; - else - { - m = gfc_match_init_expr (&c->high); - if (m == MATCH_ERROR) - goto cleanup; - /* MATCH_NO is fine. It's OK if nothing is there! */ + if (m != MATCH_YES) + goto syntax; } } - *cp = c; +done: return MATCH_YES; -need_expr: - gfc_error ("Expected initialization expression in CASE at %C"); +syntax: + gfc_syntax_error (ST_NAMELIST); -cleanup: - free_case (c); +error: return MATCH_ERROR; } -/* Match the end of a case statement. */ +/* Match a MODULE statement. */ -static match -match_case_eos (void) +match +gfc_match_module (void) { - char name[GFC_MAX_SYMBOL_LEN + 1]; match m; - if (gfc_match_eos () == MATCH_YES) - return MATCH_YES; - - /* If the case construct doesn't have a case-construct-name, we - should have matched the EOS. */ - if (!gfc_current_block ()) - return MATCH_NO; - - gfc_gobble_whitespace (); - - m = gfc_match_name (name); + m = gfc_match (" %s%t", &gfc_new_block); if (m != MATCH_YES) return m; - if (strcmp (name, gfc_current_block ()->name) != 0) - { - gfc_error ("Expected block name '%s' of SELECT construct at %C", - gfc_current_block ()->name); - return MATCH_ERROR; - } + if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE, + gfc_new_block->name, NULL) == FAILURE) + return MATCH_ERROR; - return gfc_match_eos (); + return MATCH_YES; } -/* Match a SELECT statement. */ +/* Free equivalence sets and lists. Recursively is the easiest way to + do this. */ -match -gfc_match_select (void) +void +gfc_free_equiv_until (gfc_equiv *eq, gfc_equiv *stop) { - gfc_expr *expr; - match m; - - m = gfc_match_label (); - if (m == MATCH_ERROR) - return m; + if (eq == stop) + return; - m = gfc_match (" select case ( %e )%t", &expr); - if (m != MATCH_YES) - return m; + gfc_free_equiv (eq->eq); + gfc_free_equiv_until (eq->next, stop); + gfc_free_expr (eq->expr); + free (eq); +} - new_st.op = EXEC_SELECT; - new_st.expr1 = expr; - return MATCH_YES; +void +gfc_free_equiv (gfc_equiv *eq) +{ + gfc_free_equiv_until (eq, NULL); } -/* Push the current selector onto the SELECT TYPE stack. */ +/* Match an EQUIVALENCE statement. */ -static void -select_type_push (gfc_symbol *sel) +match +gfc_match_equivalence (void) { - gfc_select_type_stack *top = gfc_get_select_type_stack (); - top->selector = sel; - top->tmp = NULL; - top->prev = select_type_stack; + gfc_equiv *eq, *set, *tail; + gfc_ref *ref; + gfc_symbol *sym; + match m; + gfc_common_head *common_head = NULL; + bool common_flag; + int cnt; - select_type_stack = top; -} + tail = NULL; + for (;;) + { + eq = gfc_get_equiv (); + if (tail == NULL) + tail = eq; -/* Set the temporary for the current SELECT TYPE selector. */ + eq->next = gfc_current_ns->equiv; + gfc_current_ns->equiv = eq; -static void -select_type_set_tmp (gfc_typespec *ts) -{ - char name[GFC_MAX_SYMBOL_LEN]; - gfc_symtree *tmp; - - if (!ts) - { - select_type_stack->tmp = NULL; - return; - } - - if (!gfc_type_is_extensible (ts->u.derived)) - return; + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; - if (ts->type == BT_CLASS) - 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); - gfc_set_sym_referenced (tmp->n.sym); - if (select_type_stack->selector->ts.type == BT_CLASS && - CLASS_DATA (select_type_stack->selector)->attr.allocatable) - gfc_add_allocatable (&tmp->n.sym->attr, NULL); - else - gfc_add_pointer (&tmp->n.sym->attr, NULL); - gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL); - if (ts->type == BT_CLASS) - gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr, - &tmp->n.sym->as, false); - tmp->n.sym->attr.select_type_temporary = 1; + set = eq; + common_flag = FALSE; + cnt = 0; - /* 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; + for (;;) + { + m = gfc_match_equiv_variable (&set->expr); + if (m == MATCH_ERROR) + goto cleanup; + if (m == MATCH_NO) + goto syntax; - select_type_stack->tmp = tmp; -} + /* count the number of objects. */ + cnt++; + + if (gfc_match_char ('%') == MATCH_YES) + { + gfc_error ("Derived type component %C is not a " + "permitted EQUIVALENCE member"); + goto cleanup; + } + for (ref = set->expr->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) + { + gfc_error ("Array reference in EQUIVALENCE at %C cannot " + "be an array section"); + goto cleanup; + } -/* Match a SELECT TYPE statement. */ + sym = set->expr->symtree->n.sym; -match -gfc_match_select_type (void) -{ - gfc_expr *expr1, *expr2 = NULL; - match m; - char name[GFC_MAX_SYMBOL_LEN]; + if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE) + goto cleanup; - m = gfc_match_label (); - if (m == MATCH_ERROR) - return m; + if (sym->attr.in_common) + { + common_flag = TRUE; + common_head = sym->common_head; + } + + if (gfc_match_char (')') == MATCH_YES) + break; - m = gfc_match (" select type ( "); - if (m != MATCH_YES) - return m; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; - gfc_current_ns = gfc_build_block_ns (gfc_current_ns); + set->eq = gfc_get_equiv (); + set = set->eq; + } - m = gfc_match (" %n => %e", name, &expr2); - if (m == MATCH_YES) - { - expr1 = gfc_get_expr(); - expr1->expr_type = EXPR_VARIABLE; - if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false)) + if (cnt < 2) { - m = MATCH_ERROR; + gfc_error ("EQUIVALENCE at %C requires two or more objects"); goto cleanup; } - if (expr2->ts.type == BT_UNKNOWN) - expr1->symtree->n.sym->attr.untyped = 1; - else - expr1->symtree->n.sym->ts = expr2->ts; - expr1->symtree->n.sym->attr.flavor = FL_VARIABLE; - expr1->symtree->n.sym->attr.referenced = 1; - expr1->symtree->n.sym->attr.class_ok = 1; - } - else - { - m = gfc_match (" %e ", &expr1); - if (m != MATCH_YES) - goto cleanup; - } - m = gfc_match (" )%t"); - if (m != MATCH_YES) - goto cleanup; + /* If one of the members of an equivalence is in common, then + mark them all as being in common. Before doing this, check + that members of the equivalence group are not in different + common blocks. */ + if (common_flag) + for (set = eq; set; set = set->eq) + { + sym = set->expr->symtree->n.sym; + if (sym->common_head && sym->common_head != common_head) + { + gfc_error ("Attempt to indirectly overlap COMMON " + "blocks %s and %s by EQUIVALENCE at %C", + sym->common_head->name, common_head->name); + goto cleanup; + } + sym->attr.in_common = 1; + sym->common_head = common_head; + } - /* Check for F03:C811. */ - if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL)) - { - gfc_error ("Selector in SELECT TYPE at %C is not a named variable; " - "use associate-name=>"); - m = MATCH_ERROR; - goto cleanup; + if (gfc_match_eos () == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + { + gfc_error ("Expecting a comma in EQUIVALENCE at %C"); + goto cleanup; + } } - new_st.op = EXEC_SELECT_TYPE; - new_st.expr1 = expr1; - new_st.expr2 = expr2; - new_st.ext.block.ns = gfc_current_ns; + return MATCH_YES; - select_type_push (expr1->symtree->n.sym); +syntax: + gfc_syntax_error (ST_EQUIVALENCE); - return MATCH_YES; - cleanup: - gfc_current_ns = gfc_current_ns->parent; - return m; + eq = tail->next; + tail->next = NULL; + + gfc_free_equiv (gfc_current_ns->equiv); + gfc_current_ns->equiv = eq; + + return MATCH_ERROR; } -/* Match a CASE statement. */ +/* Check that a statement function is not recursive. This is done by looking + for the statement function symbol(sym) by looking recursively through its + expression(e). If a reference to sym is found, true is returned. + 12.5.4 requires that any variable of function that is implicitly typed + shall have that type confirmed by any subsequent type declaration. The + implicit typing is conveniently done here. */ +static bool +recursive_stmt_fcn (gfc_expr *, gfc_symbol *); -match -gfc_match_case (void) +static bool +check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED) { - gfc_case *c, *head, *tail; - match m; - head = tail = NULL; + if (e == NULL) + return false; - if (gfc_current_state () != COMP_SELECT) + switch (e->expr_type) { - gfc_error ("Unexpected CASE statement at %C"); - return MATCH_ERROR; - } + case EXPR_FUNCTION: + if (e->symtree == NULL) + return false; - if (gfc_match ("% default") == MATCH_YES) - { - m = match_case_eos (); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; + /* Check the name before testing for nested recursion! */ + if (sym->name == e->symtree->n.sym->name) + return true; - new_st.op = EXEC_SELECT; - c = gfc_get_case (); - c->where = gfc_current_locus; - new_st.ext.block.case_list = c; - return MATCH_YES; - } + /* Catch recursion via other statement functions. */ + if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION + && e->symtree->n.sym->value + && recursive_stmt_fcn (e->symtree->n.sym->value, sym)) + return true; - if (gfc_match_char ('(') != MATCH_YES) - goto syntax; + if (e->symtree->n.sym->ts.type == BT_UNKNOWN) + gfc_set_default_type (e->symtree->n.sym, 0, NULL); - for (;;) - { - if (match_case_selector (&c) == MATCH_ERROR) - goto cleanup; + break; - if (head == NULL) - head = c; - else - tail->next = c; + case EXPR_VARIABLE: + if (e->symtree && sym->name == e->symtree->n.sym->name) + return true; - tail = c; + if (e->symtree->n.sym->ts.type == BT_UNKNOWN) + gfc_set_default_type (e->symtree->n.sym, 0, NULL); + break; - if (gfc_match_char (')') == MATCH_YES) - break; - if (gfc_match_char (',') != MATCH_YES) - goto syntax; + default: + break; } - m = match_case_eos (); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - - new_st.op = EXEC_SELECT; - new_st.ext.block.case_list = head; - - return MATCH_YES; + return false; +} -syntax: - gfc_error ("Syntax error in CASE specification at %C"); -cleanup: - gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */ - return MATCH_ERROR; +static bool +recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym) +{ + return gfc_traverse_expr (e, sym, check_stmt_fcn, 0); } -/* Match a TYPE IS statement. */ +/* Match a statement function declaration. It is so easy to match + non-statement function statements with a MATCH_ERROR as opposed to + MATCH_NO that we suppress error message in most cases. */ match -gfc_match_type_is (void) +gfc_match_st_function (void) { - gfc_case *c = NULL; + gfc_error_buf old_error; + gfc_symbol *sym; + gfc_expr *expr; match m; - if (gfc_current_state () != COMP_SELECT_TYPE) + m = gfc_match_symbol (&sym, 0); + if (m != MATCH_YES) + return m; + + gfc_push_error (&old_error); + + if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION, + sym->name, NULL) == FAILURE) + goto undo_error; + + if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES) + goto undo_error; + + m = gfc_match (" = %e%t", &expr); + if (m == MATCH_NO) + goto undo_error; + + gfc_free_error (&old_error); + if (m == MATCH_ERROR) + return m; + + if (recursive_stmt_fcn (expr, sym)) { - gfc_error ("Unexpected TYPE IS statement at %C"); + gfc_error ("Statement function at %L is recursive", &expr->where); return MATCH_ERROR; } - if (gfc_match_char ('(') != MATCH_YES) - goto syntax; + sym->value = expr; - c = gfc_get_case (); - c->where = gfc_current_locus; + if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: " + "Statement function at %C") == FAILURE) + return MATCH_ERROR; - /* TODO: Once unlimited polymorphism is implemented, we will need to call - match_type_spec here. */ - if (match_derived_type_spec (&c->ts) == MATCH_ERROR) - goto cleanup; + return MATCH_YES; - if (gfc_match_char (')') != MATCH_YES) - goto syntax; +undo_error: + gfc_pop_error (&old_error); + return MATCH_NO; +} - m = match_case_eos (); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - new_st.op = EXEC_SELECT_TYPE; - new_st.ext.block.case_list = c; +/***************** SELECT CASE subroutines ******************/ + +/* Free a single case structure. */ + +static void +free_case (gfc_case *p) +{ + if (p->low == p->high) + p->high = NULL; + gfc_free_expr (p->low); + gfc_free_expr (p->high); + free (p); +} - /* Create temporary variable. */ - select_type_set_tmp (&c->ts); - return MATCH_YES; +/* Free a list of case structures. */ -syntax: - gfc_error ("Syntax error in TYPE IS specification at %C"); +void +gfc_free_case_list (gfc_case *p) +{ + gfc_case *q; -cleanup: - if (c != NULL) - gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */ - return MATCH_ERROR; + for (; p; p = q) + { + q = p->next; + free_case (p); + } } -/* Match a CLASS IS or CLASS DEFAULT statement. */ +/* Match a single case selector. */ -match -gfc_match_class_is (void) +static match +match_case_selector (gfc_case **cp) { - gfc_case *c = NULL; + gfc_case *c; match m; - if (gfc_current_state () != COMP_SELECT_TYPE) - return MATCH_NO; + c = gfc_get_case (); + c->where = gfc_current_locus; - if (gfc_match ("% default") == MATCH_YES) + if (gfc_match_char (':') == MATCH_YES) { - m = match_case_eos (); + m = gfc_match_init_expr (&c->high); if (m == MATCH_NO) - goto syntax; + goto need_expr; + if (m == MATCH_ERROR) + goto cleanup; + } + else + { + m = gfc_match_init_expr (&c->low); if (m == MATCH_ERROR) goto cleanup; + if (m == MATCH_NO) + goto need_expr; - new_st.op = EXEC_SELECT_TYPE; - c = gfc_get_case (); - c->where = gfc_current_locus; - c->ts.type = BT_UNKNOWN; - new_st.ext.block.case_list = c; - select_type_set_tmp (NULL); - return MATCH_YES; + /* If we're not looking at a ':' now, make a range out of a single + target. Else get the upper bound for the case range. */ + if (gfc_match_char (':') != MATCH_YES) + c->high = c->low; + else + { + m = gfc_match_init_expr (&c->high); + if (m == MATCH_ERROR) + goto cleanup; + /* MATCH_NO is fine. It's OK if nothing is there! */ + } } - m = gfc_match ("% is"); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; + *cp = c; + return MATCH_YES; - if (gfc_match_char ('(') != MATCH_YES) - goto syntax; +need_expr: + gfc_error ("Expected initialization expression in CASE at %C"); - c = gfc_get_case (); - c->where = gfc_current_locus; +cleanup: + free_case (c); + return MATCH_ERROR; +} - if (match_derived_type_spec (&c->ts) == MATCH_ERROR) - goto cleanup; - if (c->ts.type == BT_DERIVED) - c->ts.type = BT_CLASS; +/* Match the end of a case statement. */ - if (gfc_match_char (')') != MATCH_YES) - goto syntax; +static match +match_case_eos (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + match m; - m = match_case_eos (); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; + if (gfc_match_eos () == MATCH_YES) + return MATCH_YES; - new_st.op = EXEC_SELECT_TYPE; - new_st.ext.block.case_list = c; - - /* Create temporary variable. */ - select_type_set_tmp (&c->ts); + /* If the case construct doesn't have a case-construct-name, we + should have matched the EOS. */ + if (!gfc_current_block ()) + return MATCH_NO; - return MATCH_YES; + gfc_gobble_whitespace (); -syntax: - gfc_error ("Syntax error in CLASS IS specification at %C"); + m = gfc_match_name (name); + if (m != MATCH_YES) + return m; -cleanup: - if (c != NULL) - gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */ - return MATCH_ERROR; -} + if (strcmp (name, gfc_current_block ()->name) != 0) + { + gfc_error ("Expected block name '%s' of SELECT construct at %C", + gfc_current_block ()->name); + return MATCH_ERROR; + } + return gfc_match_eos (); +} -/********************* WHERE subroutines ********************/ -/* Match the rest of a simple WHERE statement that follows an IF statement. - */ +/* Match a SELECT statement. */ -static match -match_simple_where (void) +match +gfc_match_select (void) { gfc_expr *expr; - gfc_code *c; match m; - m = gfc_match (" ( %e )", &expr); + m = gfc_match_label (); + if (m == MATCH_ERROR) + return m; + + m = gfc_match (" select case ( %e )%t", &expr); if (m != MATCH_YES) return m; - m = gfc_match_assignment (); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; + new_st.op = EXEC_SELECT; + new_st.expr1 = expr; - if (gfc_match_eos () != MATCH_YES) - goto syntax; + return MATCH_YES; +} - c = gfc_get_code (); - c->op = EXEC_WHERE; - c->expr1 = expr; - c->next = gfc_get_code (); +/* Push the current selector onto the SELECT TYPE stack. */ - *c->next = new_st; - gfc_clear_new_st (); +static void +select_type_push (gfc_symbol *sel) +{ + gfc_select_type_stack *top = gfc_get_select_type_stack (); + top->selector = sel; + top->tmp = NULL; + top->prev = select_type_stack; - new_st.op = EXEC_WHERE; - new_st.block = c; + select_type_stack = top; +} - return MATCH_YES; -syntax: - gfc_syntax_error (ST_WHERE); +/* Set the temporary for the current SELECT TYPE selector. */ -cleanup: - gfc_free_expr (expr); - return MATCH_ERROR; +static void +select_type_set_tmp (gfc_typespec *ts) +{ + char name[GFC_MAX_SYMBOL_LEN]; + gfc_symtree *tmp; + + if (!ts) + { + select_type_stack->tmp = NULL; + return; + } + + if (!gfc_type_is_extensible (ts->u.derived)) + return; + + if (ts->type == BT_CLASS) + 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); + gfc_set_sym_referenced (tmp->n.sym); + if (select_type_stack->selector->ts.type == BT_CLASS && + CLASS_DATA (select_type_stack->selector)->attr.allocatable) + gfc_add_allocatable (&tmp->n.sym->attr, NULL); + else + gfc_add_pointer (&tmp->n.sym->attr, NULL); + gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL); + if (ts->type == BT_CLASS) + gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr, + &tmp->n.sym->as, false); + tmp->n.sym->attr.select_type_temporary = 1; + + /* 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; } -/* Match a WHERE statement. */ +/* Match a SELECT TYPE statement. */ match -gfc_match_where (gfc_statement *st) +gfc_match_select_type (void) { - gfc_expr *expr; - match m0, m; - gfc_code *c; + gfc_expr *expr1, *expr2 = NULL; + match m; + char name[GFC_MAX_SYMBOL_LEN]; - m0 = gfc_match_label (); - if (m0 == MATCH_ERROR) - return m0; + m = gfc_match_label (); + if (m == MATCH_ERROR) + return m; - m = gfc_match (" where ( %e )", &expr); + m = gfc_match (" select type ( "); if (m != MATCH_YES) return m; - if (gfc_match_eos () == MATCH_YES) + gfc_current_ns = gfc_build_block_ns (gfc_current_ns); + + m = gfc_match (" %n => %e", name, &expr2); + if (m == MATCH_YES) + { + expr1 = gfc_get_expr(); + expr1->expr_type = EXPR_VARIABLE; + if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false)) + { + m = MATCH_ERROR; + goto cleanup; + } + if (expr2->ts.type == BT_UNKNOWN) + expr1->symtree->n.sym->attr.untyped = 1; + else + expr1->symtree->n.sym->ts = expr2->ts; + expr1->symtree->n.sym->attr.flavor = FL_VARIABLE; + expr1->symtree->n.sym->attr.referenced = 1; + expr1->symtree->n.sym->attr.class_ok = 1; + } + else { - *st = ST_WHERE_BLOCK; - new_st.op = EXEC_WHERE; - new_st.expr1 = expr; - return MATCH_YES; + m = gfc_match (" %e ", &expr1); + if (m != MATCH_YES) + goto cleanup; } - m = gfc_match_assignment (); - if (m == MATCH_NO) - gfc_syntax_error (ST_WHERE); - + m = gfc_match (" )%t"); if (m != MATCH_YES) + goto cleanup; + + /* Check for F03:C811. */ + if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL)) { - gfc_free_expr (expr); - return MATCH_ERROR; + gfc_error ("Selector in SELECT TYPE at %C is not a named variable; " + "use associate-name=>"); + m = MATCH_ERROR; + goto cleanup; } - /* We've got a simple WHERE statement. */ - *st = ST_WHERE; - c = gfc_get_code (); - - c->op = EXEC_WHERE; - c->expr1 = expr; - c->next = gfc_get_code (); - - *c->next = new_st; - gfc_clear_new_st (); + new_st.op = EXEC_SELECT_TYPE; + new_st.expr1 = expr1; + new_st.expr2 = expr2; + new_st.ext.block.ns = gfc_current_ns; - new_st.op = EXEC_WHERE; - new_st.block = c; + select_type_push (expr1->symtree->n.sym); return MATCH_YES; + +cleanup: + gfc_current_ns = gfc_current_ns->parent; + return m; } -/* Match an ELSEWHERE statement. We leave behind a WHERE node in - new_st if successful. */ +/* Match a CASE statement. */ match -gfc_match_elsewhere (void) +gfc_match_case (void) { - char name[GFC_MAX_SYMBOL_LEN + 1]; - gfc_expr *expr; + gfc_case *c, *head, *tail; match m; - if (gfc_current_state () != COMP_WHERE) + head = tail = NULL; + + if (gfc_current_state () != COMP_SELECT) { - gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block"); + gfc_error ("Unexpected CASE statement at %C"); return MATCH_ERROR; } - expr = NULL; - - if (gfc_match_char ('(') == MATCH_YES) + if (gfc_match ("% default") == MATCH_YES) { - m = gfc_match_expr (&expr); + m = match_case_eos (); if (m == MATCH_NO) goto syntax; if (m == MATCH_ERROR) - return MATCH_ERROR; + goto cleanup; - if (gfc_match_char (')') != MATCH_YES) - goto syntax; + new_st.op = EXEC_SELECT; + c = gfc_get_case (); + c->where = gfc_current_locus; + new_st.ext.block.case_list = c; + return MATCH_YES; } - if (gfc_match_eos () != MATCH_YES) + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + for (;;) { - /* Only makes sense if we have a where-construct-name. */ - if (!gfc_current_block ()) - { - m = MATCH_ERROR; - goto cleanup; - } - /* Better be a name at this point. */ - m = gfc_match_name (name); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) + if (match_case_selector (&c) == MATCH_ERROR) goto cleanup; - if (gfc_match_eos () != MATCH_YES) - goto syntax; + if (head == NULL) + head = c; + else + tail->next = c; - if (strcmp (name, gfc_current_block ()->name) != 0) - { - gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'", - name, gfc_current_block ()->name); - goto cleanup; - } + tail = c; + + if (gfc_match_char (')') == MATCH_YES) + break; + if (gfc_match_char (',') != MATCH_YES) + goto syntax; } - new_st.op = EXEC_WHERE; - new_st.expr1 = expr; + m = match_case_eos (); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + new_st.op = EXEC_SELECT; + new_st.ext.block.case_list = head; + return MATCH_YES; syntax: - gfc_syntax_error (ST_ELSEWHERE); + gfc_error ("Syntax error in CASE specification at %C"); cleanup: - gfc_free_expr (expr); + gfc_free_case_list (head); /* new_st is cleaned up in parse.c. */ return MATCH_ERROR; } -/******************** FORALL subroutines ********************/ - -/* Free a list of FORALL iterators. */ +/* Match a TYPE IS statement. */ -void -gfc_free_forall_iterator (gfc_forall_iterator *iter) +match +gfc_match_type_is (void) { - gfc_forall_iterator *next; + gfc_case *c = NULL; + match m; - while (iter) + if (gfc_current_state () != COMP_SELECT_TYPE) { - next = iter->next; - gfc_free_expr (iter->var); - gfc_free_expr (iter->start); - gfc_free_expr (iter->end); - gfc_free_expr (iter->stride); - free (iter); - iter = next; + gfc_error ("Unexpected TYPE IS statement at %C"); + return MATCH_ERROR; } -} - - -/* Match an iterator as part of a FORALL statement. The format is: - - = :[:] - - On MATCH_NO, the caller tests for the possibility that there is a - scalar mask expression. */ - -static match -match_forall_iterator (gfc_forall_iterator **result) -{ - gfc_forall_iterator *iter; - locus where; - match m; - - where = gfc_current_locus; - iter = XCNEW (gfc_forall_iterator); - m = gfc_match_expr (&iter->var); - if (m != MATCH_YES) - goto cleanup; + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; - if (gfc_match_char ('=') != MATCH_YES - || iter->var->expr_type != EXPR_VARIABLE) - { - m = MATCH_NO; - goto cleanup; - } + c = gfc_get_case (); + c->where = gfc_current_locus; - m = gfc_match_expr (&iter->start); - if (m != MATCH_YES) + /* TODO: Once unlimited polymorphism is implemented, we will need to call + match_type_spec here. */ + if (match_derived_type_spec (&c->ts) == MATCH_ERROR) goto cleanup; - if (gfc_match_char (':') != MATCH_YES) + if (gfc_match_char (')') != MATCH_YES) goto syntax; - m = gfc_match_expr (&iter->end); + m = match_case_eos (); if (m == MATCH_NO) goto syntax; if (m == MATCH_ERROR) goto cleanup; - if (gfc_match_char (':') == MATCH_NO) - iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); - else - { - m = gfc_match_expr (&iter->stride); - if (m == MATCH_NO) - goto syntax; - if (m == MATCH_ERROR) - goto cleanup; - } + new_st.op = EXEC_SELECT_TYPE; + new_st.ext.block.case_list = c; - /* Mark the iteration variable's symbol as used as a FORALL index. */ - iter->var->symtree->n.sym->forall_index = true; + /* Create temporary variable. */ + select_type_set_tmp (&c->ts); - *result = iter; return MATCH_YES; syntax: - gfc_error ("Syntax error in FORALL iterator at %C"); - m = MATCH_ERROR; + gfc_error ("Syntax error in TYPE IS specification at %C"); cleanup: + if (c != NULL) + gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */ + return MATCH_ERROR; +} - gfc_current_locus = where; - gfc_free_forall_iterator (iter); - return m; -} - - -/* Match the header of a FORALL statement. */ - -static match -match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask) -{ - gfc_forall_iterator *head, *tail, *new_iter; - gfc_expr *msk; - match m; - - gfc_gobble_whitespace (); - - head = tail = NULL; - msk = NULL; - - if (gfc_match_char ('(') != MATCH_YES) - return MATCH_NO; - - m = match_forall_iterator (&new_iter); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - - head = tail = new_iter; - - for (;;) - { - if (gfc_match_char (',') != MATCH_YES) - break; - - m = match_forall_iterator (&new_iter); - if (m == MATCH_ERROR) - goto cleanup; - - if (m == MATCH_YES) - { - tail->next = new_iter; - tail = new_iter; - continue; - } - - /* Have to have a mask expression. */ - m = gfc_match_expr (&msk); +/* Match a CLASS IS or CLASS DEFAULT statement. */ + +match +gfc_match_class_is (void) +{ + gfc_case *c = NULL; + match m; + + if (gfc_current_state () != COMP_SELECT_TYPE) + return MATCH_NO; + + if (gfc_match ("% default") == MATCH_YES) + { + m = match_case_eos (); if (m == MATCH_NO) goto syntax; if (m == MATCH_ERROR) goto cleanup; - break; + new_st.op = EXEC_SELECT_TYPE; + c = gfc_get_case (); + c->where = gfc_current_locus; + c->ts.type = BT_UNKNOWN; + new_st.ext.block.case_list = c; + select_type_set_tmp (NULL); + return MATCH_YES; } - if (gfc_match_char (')') == MATCH_NO) + m = gfc_match ("% is"); + if (m == MATCH_NO) goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + c = gfc_get_case (); + c->where = gfc_current_locus; + + if (match_derived_type_spec (&c->ts) == MATCH_ERROR) + goto cleanup; + + if (c->ts.type == BT_DERIVED) + c->ts.type = BT_CLASS; + + 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_TYPE; + new_st.ext.block.case_list = c; + + /* Create temporary variable. */ + select_type_set_tmp (&c->ts); - *phead = head; - *mask = msk; return MATCH_YES; syntax: - gfc_syntax_error (ST_FORALL); + gfc_error ("Syntax error in CLASS IS specification at %C"); cleanup: - gfc_free_expr (msk); - gfc_free_forall_iterator (head); - + if (c != NULL) + gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */ return MATCH_ERROR; } -/* Match the rest of a simple FORALL statement that follows an - IF statement. */ + +/********************* WHERE subroutines ********************/ + +/* Match the rest of a simple WHERE statement that follows an IF statement. + */ static match -match_simple_forall (void) +match_simple_where (void) { - gfc_forall_iterator *head; - gfc_expr *mask; + gfc_expr *expr; gfc_code *c; match m; - mask = NULL; - head = NULL; - c = NULL; - - m = match_forall_header (&head, &mask); - - if (m == MATCH_NO) - goto syntax; + m = gfc_match (" ( %e )", &expr); if (m != MATCH_YES) - goto cleanup; + return m; m = gfc_match_assignment (); - + if (m == MATCH_NO) + goto syntax; if (m == MATCH_ERROR) goto cleanup; - if (m == MATCH_NO) - { - m = gfc_match_pointer_assignment (); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - } - - c = gfc_get_code (); - *c = new_st; - c->loc = gfc_current_locus; if (gfc_match_eos () != MATCH_YES) goto syntax; + c = gfc_get_code (); + + c->op = EXEC_WHERE; + c->expr1 = expr; + c->next = gfc_get_code (); + + *c->next = new_st; gfc_clear_new_st (); - new_st.op = EXEC_FORALL; - new_st.expr1 = mask; - new_st.ext.forall_iterator = head; - new_st.block = gfc_get_code (); - new_st.block->op = EXEC_FORALL; - new_st.block->next = c; + new_st.op = EXEC_WHERE; + new_st.block = c; return MATCH_YES; syntax: - gfc_syntax_error (ST_FORALL); + gfc_syntax_error (ST_WHERE); cleanup: - gfc_free_forall_iterator (head); - gfc_free_expr (mask); - + gfc_free_expr (expr); return MATCH_ERROR; } -/* Match a FORALL statement. */ +/* Match a WHERE statement. */ match -gfc_match_forall (gfc_statement *st) +gfc_match_where (gfc_statement *st) { - gfc_forall_iterator *head; - gfc_expr *mask; - gfc_code *c; + gfc_expr *expr; match m0, m; - - head = NULL; - mask = NULL; - c = NULL; + gfc_code *c; m0 = gfc_match_label (); if (m0 == MATCH_ERROR) - return MATCH_ERROR; + return m0; - m = gfc_match (" forall"); + m = gfc_match (" where ( %e )", &expr); if (m != MATCH_YES) return m; - m = match_forall_header (&head, &mask); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; - if (gfc_match_eos () == MATCH_YES) { - *st = ST_FORALL_BLOCK; - new_st.op = EXEC_FORALL; - new_st.expr1 = mask; - new_st.ext.forall_iterator = head; + *st = ST_WHERE_BLOCK; + new_st.op = EXEC_WHERE; + new_st.expr1 = expr; return MATCH_YES; } m = gfc_match_assignment (); - if (m == MATCH_ERROR) - goto cleanup; if (m == MATCH_NO) + gfc_syntax_error (ST_WHERE); + + if (m != MATCH_YES) { - m = gfc_match_pointer_assignment (); - if (m == MATCH_ERROR) - goto cleanup; - if (m == MATCH_NO) - goto syntax; + gfc_free_expr (expr); + return MATCH_ERROR; } + /* We've got a simple WHERE statement. */ + *st = ST_WHERE; c = gfc_get_code (); - *c = new_st; - c->loc = gfc_current_locus; + c->op = EXEC_WHERE; + c->expr1 = expr; + c->next = gfc_get_code (); + + *c->next = new_st; gfc_clear_new_st (); - new_st.op = EXEC_FORALL; - new_st.expr1 = mask; - new_st.ext.forall_iterator = head; - new_st.block = gfc_get_code (); - new_st.block->op = EXEC_FORALL; - new_st.block->next = c; - *st = ST_FORALL; + new_st.op = EXEC_WHERE; + new_st.block = c; + + return MATCH_YES; +} + + +/* Match an ELSEWHERE statement. We leave behind a WHERE node in + new_st if successful. */ + +match +gfc_match_elsewhere (void) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_expr *expr; + match m; + + if (gfc_current_state () != COMP_WHERE) + { + gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block"); + return MATCH_ERROR; + } + + expr = NULL; + + if (gfc_match_char ('(') == MATCH_YES) + { + m = gfc_match_expr (&expr); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + return MATCH_ERROR; + + if (gfc_match_char (')') != MATCH_YES) + goto syntax; + } + + if (gfc_match_eos () != MATCH_YES) + { + /* Only makes sense if we have a where-construct-name. */ + if (!gfc_current_block ()) + { + m = MATCH_ERROR; + goto cleanup; + } + /* Better be a name at this point. */ + m = gfc_match_name (name); + if (m == MATCH_NO) + goto syntax; + if (m == MATCH_ERROR) + goto cleanup; + + if (gfc_match_eos () != MATCH_YES) + goto syntax; + + if (strcmp (name, gfc_current_block ()->name) != 0) + { + gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'", + name, gfc_current_block ()->name); + goto cleanup; + } + } + + new_st.op = EXEC_WHERE; + new_st.expr1 = expr; return MATCH_YES; syntax: - gfc_syntax_error (ST_FORALL); + gfc_syntax_error (ST_ELSEWHERE); cleanup: - gfc_free_forall_iterator (head); - gfc_free_expr (mask); - gfc_free_statements (c); - return MATCH_NO; + gfc_free_expr (expr); + return MATCH_ERROR; } diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 9b1108671511..24d8960d06be 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -3154,7 +3154,7 @@ check_do_closure (void) return 0; for (p = gfc_state_stack; p; p = p->previous) - if (p->state == COMP_DO) + if (p->state == COMP_DO || p->state == COMP_DO_CONCURRENT) break; if (p == NULL) @@ -3172,7 +3172,8 @@ check_do_closure (void) /* At this point, the label doesn't terminate the innermost loop. Make sure it doesn't terminate another one. */ for (; p; p = p->previous) - if (p->state == COMP_DO && p->ext.end_do_label == gfc_statement_label) + if ((p->state == COMP_DO || p->state == COMP_DO_CONCURRENT) + && p->ext.end_do_label == gfc_statement_label) { gfc_error ("End of nonblock DO statement at %C is interwoven " "with another DO loop"); @@ -3387,7 +3388,9 @@ parse_do_block (void) gfc_code *top; gfc_state_data s; gfc_symtree *stree; + gfc_exec_op do_op; + do_op = new_st.op; s.ext.end_do_label = new_st.label1; if (new_st.ext.iterator != NULL) @@ -3398,7 +3401,8 @@ parse_do_block (void) accept_statement (ST_DO); top = gfc_state_stack->tail; - push_state (&s, COMP_DO, gfc_new_block); + push_state (&s, do_op == EXEC_DO_CONCURRENT ? COMP_DO_CONCURRENT : COMP_DO, + gfc_new_block); s.do_variable = stree; diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index b18056c1cd75..9e56b81dc866 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -30,7 +30,7 @@ typedef enum COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_DERIVED_CONTAINS, COMP_BLOCK, COMP_ASSOCIATE, COMP_IF, COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM, - COMP_SELECT_TYPE, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL + COMP_SELECT_TYPE, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL, COMP_DO_CONCURRENT } gfc_compile_state; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index a12e6e746750..b038402ac291 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -58,9 +58,10 @@ code_stack; static code_stack *cs_base = NULL; -/* Nonzero if we're inside a FORALL block. */ +/* Nonzero if we're inside a FORALL or DO CONCURRENT block. */ static int forall_flag; +static int do_concurrent_flag; /* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */ @@ -3159,11 +3160,18 @@ resolve_function (gfc_expr *expr) { if (forall_flag) { - gfc_error ("reference to non-PURE function '%s' at %L inside a " + gfc_error ("Reference to non-PURE function '%s' at %L inside a " "FORALL %s", name, &expr->where, forall_flag == 2 ? "mask" : "block"); t = FAILURE; } + else if (do_concurrent_flag) + { + gfc_error ("Reference to non-PURE function '%s' at %L inside a " + "DO CONCURRENT %s", name, &expr->where, + do_concurrent_flag == 2 ? "mask" : "block"); + t = FAILURE; + } else if (gfc_pure (NULL)) { gfc_error ("Function reference to '%s' at %L is to a non-PURE " @@ -3230,6 +3238,9 @@ pure_subroutine (gfc_code *c, gfc_symbol *sym) if (forall_flag) gfc_error ("Subroutine call to '%s' in FORALL block at %L is not PURE", sym->name, &c->loc); + else if (do_concurrent_flag) + gfc_error ("Subroutine call to '%s' in DO CONCURRENT block at %L is not " + "PURE", sym->name, &c->loc); else if (gfc_pure (NULL)) gfc_error ("Subroutine call to '%s' at %L is not PURE", sym->name, &c->loc); @@ -8385,10 +8396,16 @@ resolve_branch (gfc_st_label *label, gfc_code *code) whether the label is still visible outside of the CRITICAL block, which is invalid. */ for (stack = cs_base; stack; stack = stack->prev) - if (stack->current->op == EXEC_CRITICAL - && bitmap_bit_p (stack->reachable_labels, label->value)) - gfc_error ("GOTO statement at %L leaves CRITICAL construct for label" - " at %L", &code->loc, &label->where); + { + if (stack->current->op == EXEC_CRITICAL + && bitmap_bit_p (stack->reachable_labels, label->value)) + gfc_error ("GOTO statement at %L leaves CRITICAL construct for " + "label at %L", &code->loc, &label->where); + else if (stack->current->op == EXEC_DO_CONCURRENT + && bitmap_bit_p (stack->reachable_labels, label->value)) + gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct " + "for label at %L", &code->loc, &label->where); + } return; } @@ -8409,6 +8426,12 @@ resolve_branch (gfc_st_label *label, gfc_code *code) " at %L", &code->loc, &label->where); return; } + else if (stack->current->op == EXEC_DO_CONCURRENT) + { + gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for " + "label at %L", &code->loc, &label->where); + return; + } } if (stack) @@ -8832,6 +8855,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) case EXEC_FORALL: case EXEC_DO: case EXEC_DO_WHILE: + case EXEC_DO_CONCURRENT: case EXEC_CRITICAL: case EXEC_READ: case EXEC_WRITE: @@ -9071,7 +9095,7 @@ static void resolve_code (gfc_code *code, gfc_namespace *ns) { int omp_workshare_save; - int forall_save; + int forall_save, do_concurrent_save; code_stack frame; gfc_try t; @@ -9085,6 +9109,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) { frame.current = code; forall_save = forall_flag; + do_concurrent_save = do_concurrent_flag; if (code->op == EXEC_FORALL) { @@ -9117,6 +9142,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns) /* Blocks are handled in resolve_select_type because we have to transform the SELECT TYPE into ASSOCIATE first. */ break; + case EXEC_DO_CONCURRENT: + do_concurrent_flag = 1; + gfc_resolve_blocks (code->block, ns); + do_concurrent_flag = 2; + break; case EXEC_OMP_WORKSHARE: omp_workshare_save = omp_workshare_flag; omp_workshare_flag = 1; @@ -9134,6 +9164,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC) t = gfc_resolve_expr (code->expr1); forall_flag = forall_save; + do_concurrent_flag = do_concurrent_save; if (gfc_resolve_expr (code->expr2) == FAILURE) t = FAILURE; @@ -9401,6 +9432,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns) resolve_transfer (code); break; + case EXEC_DO_CONCURRENT: case EXEC_FORALL: resolve_forall_iterators (code->ext.forall_iterator); @@ -13570,6 +13602,7 @@ resolve_types (gfc_namespace *ns) } forall_flag = 0; + do_concurrent_flag = 0; gfc_check_interfaces (ns); gfc_traverse_ns (ns, resolve_values); diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c index 572baafc3e99..932c9428af86 100644 --- a/gcc/fortran/st.c +++ b/gcc/fortran/st.c @@ -178,6 +178,7 @@ gfc_free_statement (gfc_code *p) be freed. */ break; + case EXEC_DO_CONCURRENT: case EXEC_FORALL: gfc_free_forall_iterator (p->ext.forall_iterator); break; diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 7d8b4e00827f..1fdb0590d5a4 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -3514,6 +3514,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) tree maskindex; tree mask; tree pmask; + tree cycle_label = NULL_TREE; int n; int nvar; int need_temp; @@ -3703,6 +3704,26 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) gfc_add_expr_to_block (&block, tmp); } + if (code->op == EXEC_DO_CONCURRENT) + { + gfc_init_block (&body); + cycle_label = gfc_build_label_decl (NULL_TREE); + code->cycle_label = cycle_label; + tmp = gfc_trans_code (code->block->next); + gfc_add_expr_to_block (&body, tmp); + + if (TREE_USED (cycle_label)) + { + tmp = build1_v (LABEL_EXPR, cycle_label); + gfc_add_expr_to_block (&body, tmp); + } + + tmp = gfc_finish_block (&body); + tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); + gfc_add_expr_to_block (&block, tmp); + goto done; + } + c = code->block->next; /* TODO: loop merging in FORALL statements. */ @@ -3783,6 +3804,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) c = c->next; } +done: /* Restore the original index variables. */ for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++) gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]); @@ -3829,6 +3851,14 @@ tree gfc_trans_forall (gfc_code * code) } +/* Translate the DO CONCURRENT construct. */ + +tree gfc_trans_do_concurrent (gfc_code * code) +{ + return gfc_trans_forall_1 (code, NULL); +} + + /* Evaluate the WHERE mask expression, copy its value to a temporary. If the WHERE construct is nested in FORALL, compute the overall temporary needed by the WHERE mask expression multiplied by the iterator number of diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h index 2d0faf17fb7c..caa4c982b17c 100644 --- a/gcc/fortran/trans-stmt.h +++ b/gcc/fortran/trans-stmt.h @@ -51,6 +51,7 @@ tree gfc_trans_if (gfc_code *); tree gfc_trans_arithmetic_if (gfc_code *); tree gfc_trans_block_construct (gfc_code *); tree gfc_trans_do (gfc_code *, tree); +tree gfc_trans_do_concurrent (gfc_code *); tree gfc_trans_do_while (gfc_code *); tree gfc_trans_select (gfc_code *); tree gfc_trans_sync (gfc_code *, gfc_exec_op); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 4a71c43fdcc5..764bdf42e456 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1303,6 +1303,10 @@ trans_code (gfc_code * code, tree cond) res = gfc_trans_do (code, cond); break; + case EXEC_DO_CONCURRENT: + res = gfc_trans_do_concurrent (code); + break; + case EXEC_DO_WHILE: res = gfc_trans_do_while (code); break; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 364d0dcf9966..18b487d063c3 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2011-09-08 Tobias Burnus + + PR fortran/44646 + * gfortran.dg/do_concurrent_1.f90: New. + * gfortran.dg/do_concurrent_2.f90: New. + 2011-09-08 Jakub Jelinek PR target/50310 diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_1.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_1.f90 new file mode 100644 index 000000000000..944591087aa3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/do_concurrent_1.f90 @@ -0,0 +1,71 @@ +! { dg-do compile } +! { dg-options "-fcoarray=single" } +! +! PR fortran/44646 +! +! DO CONCURRENT +! +implicit none +integer :: i, j + +outer: do, concurrent ( i = 1 : 4) + do j = 1, 5 + if (j == 1) cycle ! OK + cycle outer ! OK: C821 FIXME + exit outer ! { dg-error "EXIT statement at .1. leaves DO CONCURRENT construct" } + end do +end do outer + +do concurrent (j = 1:5) + cycle ! OK +end do + +outer2: do j = 1, 7 + do concurrent (j=1:5:2) ! cycle outer2 - bad: C821 + cycle outer2 ! { dg-error "leaves DO CONCURRENT construct" } + end do +end do outer2 + +do concurrent ( i = 1 : 4) + exit ! { dg-error "EXIT statement at .1. leaves DO CONCURRENT construct" } +end do +end + +subroutine foo() + do concurrent ( i = 1 : 4) + return ! { dg-error "Image control statement RETURN" } + sync all ! { dg-error "Image control statement SYNC" } + call test () ! { dg-error "Subroutine call to .test. in DO CONCURRENT block at .1. is not PURE" } + stop ! { dg-error "Image control statement STOP" } + end do + do concurrent ( i = 1 : 4) + critical ! { dg-error "Image control statement CRITICAL at .1. in DO CONCURRENT block" } + print *, i +! end critical + end do + + critical + do concurrent ( i = 1 : 4) ! OK + end do + end critical +end + +subroutine caf() + use iso_fortran_env + implicit none + type(lock_type), allocatable :: lock[:] + integer :: i + do, concurrent (i = 1:3) + allocate (lock[*]) ! { dg-error "ALLOCATE of coarray at .1. in DO CONCURRENT block" } + lock(lock) ! { dg-error "Image control statement LOCK" } + unlock(lock) ! { dg-error "Image control statement UNLOCK" } + deallocate (lock) ! { dg-error "DEALLOCATE of coarray at .1. in DO CONCURRENT block" } + end do + + critical + allocate (lock[*]) ! { dg-error "ALLOCATE of coarray at .1. in CRITICAL block" } + lock(lock) ! { dg-error "Image control statement LOCK" } + unlock(lock) ! { dg-error "Image control statement UNLOCK" } + deallocate (lock) ! { dg-error "DEALLOCATE of coarray at .1. in CRITICAL block" } + end critical +end subroutine caf diff --git a/gcc/testsuite/gfortran.dg/do_concurrent_2.f90 b/gcc/testsuite/gfortran.dg/do_concurrent_2.f90 new file mode 100644 index 000000000000..b059356c7194 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/do_concurrent_2.f90 @@ -0,0 +1,40 @@ +! { dg-do run } +! +! PR fortran/44646 +! +! DO CONCURRENT +! +implicit none +integer :: i, j +integer :: A(5,5) + +A = 0.0 +do concurrent (i=1:5, j=1:5, (i/=j)) + if (i == 5) cycle + A(i,j) = i*j +end do + +if (any (A(:,1) /= [0, 2, 3, 4, 0])) call abort() +if (any (A(:,2) /= [2, 0, 6, 8, 0])) call abort() +if (any (A(:,3) /= [3, 6, 0, 12, 0])) call abort() +if (any (A(:,4) /= [4, 8, 12, 0, 0])) call abort() +if (any (A(:,5) /= [5, 10, 15, 20, 0])) call abort() + +A = -99 + +do concurrent (i = 1 : 5) + forall (j=1:4, i/=j) + A(i,j) = i*j + end forall + if (i == 5) then + A(i,i) = -i + end if +end do + +if (any (A(:,1) /= [-99, 2, 3, 4, 5])) call abort () +if (any (A(:,2) /= [ 2, -99, 6, 8, 10])) call abort () +if (any (A(:,3) /= [ 3, 6, -99, 12, 15])) call abort () +if (any (A(:,4) /= [ 4, 8, 12, -99, 20])) call abort () +if (any (A(:,5) /= [-99, -99, -99, -99, -5])) call abort () + +end