2011-09-03 Tobias Burnus <burnus@net-b.de>
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.
* trans-stmt.h (gfc_trans_do_concurrent): Ditto.
* trans.c (trans_code): Call it.
2011-09-03 Tobias Burnus <burnus@net-b.de>
PR fortran/44646
* gfortran.dg/do_concurrent_1.f90: New.
@@ -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;
@@ -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);
@@ -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,
@@ -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,6 +1900,436 @@ error:
}
+/* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
+ an accessible derived type. */
+
+static match
+match_derived_type_spec (gfc_typespec *ts)
+{
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ locus old_locus;
+ gfc_symbol *derived;
+
+ old_locus = gfc_current_locus;
+
+ if (gfc_match ("%n", name) != MATCH_YES)
+ {
+ gfc_current_locus = old_locus;
+ return MATCH_NO;
+ }
+
+ gfc_find_symbol (name, NULL, 1, &derived);
+
+ if (derived && derived->attr.flavor == FL_DERIVED)
+ {
+ ts->type = BT_DERIVED;
+ ts->u.derived = derived;
+ return MATCH_YES;
+ }
+
+ gfc_current_locus = old_locus;
+ return MATCH_NO;
+}
+
+
+/* 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)
+ {
+ /* 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;
+ }
+
+ if (gfc_match ("integer") == MATCH_YES)
+ {
+ ts->type = BT_INTEGER;
+ ts->kind = gfc_default_integer_kind;
+ goto kind_selector;
+ }
+
+ if (gfc_match ("real") == MATCH_YES)
+ {
+ ts->type = BT_REAL;
+ ts->kind = gfc_default_real_kind;
+ goto kind_selector;
+ }
+
+ if (gfc_match ("double precision") == MATCH_YES)
+ {
+ ts->type = BT_REAL;
+ ts->kind = gfc_default_double_kind;
+ return MATCH_YES;
+ }
+
+ if (gfc_match ("complex") == MATCH_YES)
+ {
+ ts->type = BT_COMPLEX;
+ ts->kind = gfc_default_complex_kind;
+ goto kind_selector;
+ }
+
+ if (gfc_match ("character") == MATCH_YES)
+ {
+ ts->type = BT_CHARACTER;
+
+ m = gfc_match_char_spec (ts);
+
+ if (m == MATCH_NO)
+ m = MATCH_YES;
+
+ return m;
+ }
+
+ if (gfc_match ("logical") == MATCH_YES)
+ {
+ ts->type = BT_LOGICAL;
+ ts->kind = gfc_default_logical_kind;
+ goto kind_selector;
+ }
+
+ /* If a type is not matched, simply return MATCH_NO. */
+ gfc_current_locus = old_locus;
+ return MATCH_NO;
+
+kind_selector:
+
+ gfc_gobble_whitespace ();
+ if (gfc_peek_ascii_char () == '*')
+ {
+ gfc_error ("Invalid type-spec at %C");
+ return MATCH_ERROR;
+ }
+
+ m = gfc_match_kind_spec (ts, false);
+
+ if (m == MATCH_NO)
+ m = MATCH_YES; /* No kind specifier found. */
+
+ return m;
+}
+
+
+/******************** FORALL subroutines ********************/
+
+/* Free a list of FORALL iterators. */
+
+void
+gfc_free_forall_iterator (gfc_forall_iterator *iter)
+{
+ gfc_forall_iterator *next;
+
+ while (iter)
+ {
+ 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;
+ }
+}
+
+
+/* Match an iterator as part of a FORALL statement. The format is:
+
+ <var> = <start>:<end>[:<stride>]
+
+ 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
+ || iter->var->expr_type != EXPR_VARIABLE)
+ {
+ m = MATCH_NO;
+ goto cleanup;
+ }
+
+ m = gfc_match_expr (&iter->start);
+ if (m != MATCH_YES)
+ goto cleanup;
+
+ if (gfc_match_char (':') != MATCH_YES)
+ goto syntax;
+
+ m = gfc_match_expr (&iter->end);
+ 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;
+ }
+
+ /* 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;
+
+syntax:
+ gfc_error ("Syntax error in FORALL iterator at %C");
+ m = MATCH_ERROR;
+
+cleanup:
+
+ 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);
+ if (m == MATCH_NO)
+ goto syntax;
+ if (m == MATCH_ERROR)
+ goto cleanup;
+
+ break;
+ }
+
+ if (gfc_match_char (')') == MATCH_NO)
+ goto syntax;
+
+ *phead = head;
+ *mask = msk;
+ return MATCH_YES;
+
+syntax:
+ gfc_syntax_error (ST_FORALL);
+
+cleanup:
+ gfc_free_expr (msk);
+ gfc_free_forall_iterator (head);
+
+ return MATCH_ERROR;
+}
+
+/* Match the rest of a simple FORALL statement that follows an
+ IF statement. */
+
+static match
+match_simple_forall (void)
+{
+ gfc_forall_iterator *head;
+ gfc_expr *mask;
+ gfc_code *c;
+ match m;
+
+ mask = NULL;
+ head = NULL;
+ c = NULL;
+
+ m = match_forall_header (&head, &mask);
+
+ if (m == MATCH_NO)
+ goto syntax;
+ if (m != MATCH_YES)
+ goto cleanup;
+
+ 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;
+ }
+
+ c = gfc_get_code ();
+ *c = new_st;
+ c->loc = gfc_current_locus;
+
+ if (gfc_match_eos () != MATCH_YES)
+ goto syntax;
+
+ 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;
+
+ return MATCH_YES;
+
+syntax:
+ gfc_syntax_error (ST_FORALL);
+
+cleanup:
+ gfc_free_forall_iterator (head);
+ gfc_free_expr (mask);
+
+ return MATCH_ERROR;
+}
+
+
+/* Match a FORALL statement. */
+
+match
+gfc_match_forall (gfc_statement *st)
+{
+ gfc_forall_iterator *head;
+ gfc_expr *mask;
+ gfc_code *c;
+ match m0, m;
+
+ head = NULL;
+ mask = NULL;
+ c = NULL;
+
+ 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 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;
+ return MATCH_YES;
+ }
+
+ 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;
+ }
+
+ c = gfc_get_code ();
+ *c = new_st;
+ c->loc = gfc_current_locus;
+
+ 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;
+ return MATCH_YES;
+
+syntax:
+ gfc_syntax_error (ST_FORALL);
+
+cleanup:
+ gfc_free_forall_iterator (head);
+ gfc_free_expr (mask);
+ gfc_free_statements (c);
+ return MATCH_NO;
+}
+
+
/* Match a DO statement. */
match
@@ -1937,6 +2374,46 @@ gfc_match_do (void)
if (gfc_match_parens () == MATCH_ERROR)
return MATCH_ERROR;
+ 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;
+
+
+ mask = NULL;
+ head = NULL;
+ m = match_forall_header (&head, &mask);
+
+ if (m == MATCH_NO)
+ return m;
+ if (m == MATCH_ERROR)
+ goto concurr_cleanup;
+
+ if (gfc_match_eos () != MATCH_YES)
+ goto concurr_cleanup;
+
+ if (label != NULL
+ && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
+ goto concurr_cleanup;
+
+ new_st.label1 = label;
+ new_st.op = EXEC_DO_CONCURRENT;
+ new_st.expr1 = mask;
+ new_st.ext.forall_iterator = head;
+
+ return MATCH_YES;
+
+concurr_cleanup:
+ gfc_syntax_error (ST_DO);
+ gfc_free_expr (mask);
+ gfc_free_forall_iterator (head);
+ return MATCH_ERROR;
+ }
+
/* See if we have a DO WHILE. */
if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
{
@@ -2052,6 +2529,14 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op)
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))
break;
@@ -2071,6 +2556,7 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op)
switch (p->state)
{
case COMP_DO:
+ case COMP_DO_CONCURRENT:
break;
case COMP_CRITICAL:
@@ -2202,6 +2688,11 @@ gfc_match_stopcode (gfc_statement st)
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;
+ }
if (e != NULL)
{
@@ -2325,7 +2816,8 @@ lock_unlock_statement (gfc_statement st)
if (gfc_pure (NULL))
{
- gfc_error ("Image control statement SYNC at %C in PURE procedure");
+ gfc_error ("Image control statement %s at %C in PURE procedure",
+ st == ST_LOCK ? "LOCK" : "UNLOCK");
return MATCH_ERROR;
}
@@ -2340,7 +2832,15 @@ lock_unlock_statement (gfc_statement st)
if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
{
- gfc_error ("Image control statement SYNC at %C in CRITICAL block");
+ gfc_error ("Image control statement %s at %C in CRITICAL block",
+ st == ST_LOCK ? "LOCK" : "UNLOCK");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
+ {
+ gfc_error ("Image control statement %s at %C in DO CONCURRENT block",
+ st == ST_LOCK ? "LOCK" : "UNLOCK");
return MATCH_ERROR;
}
@@ -2532,6 +3032,12 @@ sync_statement (gfc_statement st)
return MATCH_ERROR;
}
+ if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
+ {
+ gfc_error ("Image control statement SYNC at %C in DO CONCURRENT block");
+ return MATCH_ERROR;
+ }
+
if (gfc_match_eos () == MATCH_YES)
{
if (st == ST_SYNC_IMAGES)
@@ -2905,136 +3411,6 @@ gfc_free_alloc_list (gfc_alloc *p)
}
-/* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
- an accessible derived type. */
-
-static match
-match_derived_type_spec (gfc_typespec *ts)
-{
- char name[GFC_MAX_SYMBOL_LEN + 1];
- locus old_locus;
- gfc_symbol *derived;
-
- old_locus = gfc_current_locus;
-
- if (gfc_match ("%n", name) != MATCH_YES)
- {
- gfc_current_locus = old_locus;
- return MATCH_NO;
- }
-
- gfc_find_symbol (name, NULL, 1, &derived);
-
- if (derived && derived->attr.flavor == FL_DERIVED)
- {
- ts->type = BT_DERIVED;
- ts->u.derived = derived;
- return MATCH_YES;
- }
-
- gfc_current_locus = old_locus;
- return MATCH_NO;
-}
-
-
-/* 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)
- {
- /* 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;
- }
-
- if (gfc_match ("integer") == MATCH_YES)
- {
- ts->type = BT_INTEGER;
- ts->kind = gfc_default_integer_kind;
- goto kind_selector;
- }
-
- if (gfc_match ("real") == MATCH_YES)
- {
- ts->type = BT_REAL;
- ts->kind = gfc_default_real_kind;
- goto kind_selector;
- }
-
- if (gfc_match ("double precision") == MATCH_YES)
- {
- ts->type = BT_REAL;
- ts->kind = gfc_default_double_kind;
- return MATCH_YES;
- }
-
- if (gfc_match ("complex") == MATCH_YES)
- {
- ts->type = BT_COMPLEX;
- ts->kind = gfc_default_complex_kind;
- goto kind_selector;
- }
-
- if (gfc_match ("character") == MATCH_YES)
- {
- ts->type = BT_CHARACTER;
-
- m = gfc_match_char_spec (ts);
-
- if (m == MATCH_NO)
- m = MATCH_YES;
-
- return m;
- }
-
- if (gfc_match ("logical") == MATCH_YES)
- {
- ts->type = BT_LOGICAL;
- ts->kind = gfc_default_logical_kind;
- goto kind_selector;
- }
-
- /* If a type is not matched, simply return MATCH_NO. */
- gfc_current_locus = old_locus;
- return MATCH_NO;
-
-kind_selector:
-
- gfc_gobble_whitespace ();
- if (gfc_peek_ascii_char () == '*')
- {
- gfc_error ("Invalid type-spec at %C");
- return MATCH_ERROR;
- }
-
- m = gfc_match_kind_spec (ts, false);
-
- if (m == MATCH_NO)
- m = MATCH_YES; /* No kind specifier found. */
-
- return m;
-}
-
-
/* Match an ALLOCATE statement. */
match
@@ -3129,6 +3505,27 @@ gfc_match_allocate (void)
deferred_locus = tail->expr->where;
}
+ 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;
+
+ 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;
+ }
+ }
+
/* The ALLOCATE statement had an optional typespec. Check the
constraints. */
if (ts.type != BT_UNKNOWN)
@@ -3477,6 +3874,20 @@ gfc_match_deallocate (void)
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
@@ -3588,6 +3999,12 @@ gfc_match_return (void)
return MATCH_ERROR;
}
+ if (gfc_find_state (COMP_DO_CONCURRENT) == SUCCESS)
+ {
+ gfc_error ("Image control statement RETURN at %C in DO CONCURRENT block");
+ return MATCH_ERROR;
+ }
+
if (gfc_match_eos () == MATCH_YES)
goto done;
@@ -5188,303 +5605,3 @@ cleanup:
gfc_free_expr (expr);
return MATCH_ERROR;
}
-
-
-/******************** FORALL subroutines ********************/
-
-/* Free a list of FORALL iterators. */
-
-void
-gfc_free_forall_iterator (gfc_forall_iterator *iter)
-{
- gfc_forall_iterator *next;
-
- while (iter)
- {
- 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;
- }
-}
-
-
-/* Match an iterator as part of a FORALL statement. The format is:
-
- <var> = <start>:<end>[:<stride>]
-
- 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
- || iter->var->expr_type != EXPR_VARIABLE)
- {
- m = MATCH_NO;
- goto cleanup;
- }
-
- m = gfc_match_expr (&iter->start);
- if (m != MATCH_YES)
- goto cleanup;
-
- if (gfc_match_char (':') != MATCH_YES)
- goto syntax;
-
- m = gfc_match_expr (&iter->end);
- 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;
- }
-
- /* 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;
-
-syntax:
- gfc_error ("Syntax error in FORALL iterator at %C");
- m = MATCH_ERROR;
-
-cleanup:
-
- 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);
- if (m == MATCH_NO)
- goto syntax;
- if (m == MATCH_ERROR)
- goto cleanup;
-
- break;
- }
-
- if (gfc_match_char (')') == MATCH_NO)
- goto syntax;
-
- *phead = head;
- *mask = msk;
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (ST_FORALL);
-
-cleanup:
- gfc_free_expr (msk);
- gfc_free_forall_iterator (head);
-
- return MATCH_ERROR;
-}
-
-/* Match the rest of a simple FORALL statement that follows an
- IF statement. */
-
-static match
-match_simple_forall (void)
-{
- gfc_forall_iterator *head;
- gfc_expr *mask;
- gfc_code *c;
- match m;
-
- mask = NULL;
- head = NULL;
- c = NULL;
-
- m = match_forall_header (&head, &mask);
-
- if (m == MATCH_NO)
- goto syntax;
- if (m != MATCH_YES)
- goto cleanup;
-
- 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;
- }
-
- c = gfc_get_code ();
- *c = new_st;
- c->loc = gfc_current_locus;
-
- if (gfc_match_eos () != MATCH_YES)
- goto syntax;
-
- 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;
-
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (ST_FORALL);
-
-cleanup:
- gfc_free_forall_iterator (head);
- gfc_free_expr (mask);
-
- return MATCH_ERROR;
-}
-
-
-/* Match a FORALL statement. */
-
-match
-gfc_match_forall (gfc_statement *st)
-{
- gfc_forall_iterator *head;
- gfc_expr *mask;
- gfc_code *c;
- match m0, m;
-
- head = NULL;
- mask = NULL;
- c = NULL;
-
- 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 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;
- return MATCH_YES;
- }
-
- 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;
- }
-
- c = gfc_get_code ();
- *c = new_st;
- c->loc = gfc_current_locus;
-
- 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;
- return MATCH_YES;
-
-syntax:
- gfc_syntax_error (ST_FORALL);
-
-cleanup:
- gfc_free_forall_iterator (head);
- gfc_free_expr (mask);
- gfc_free_statements (c);
- return MATCH_NO;
-}
@@ -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;
@@ -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;
@@ -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. */
@@ -3125,11 +3126,17 @@ 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 block", name, &expr->where);
+ t = FAILURE;
+ }
else if (gfc_pure (NULL))
{
gfc_error ("Function reference to '%s' at %L is to a non-PURE "
@@ -3196,6 +3203,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);
@@ -8351,10 +8361,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;
}
@@ -8375,6 +8391,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)
@@ -8798,6 +8820,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:
@@ -9037,7 +9060,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;
@@ -9051,6 +9074,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)
{
@@ -9083,6 +9107,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;
@@ -9100,6 +9129,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;
@@ -9367,6 +9397,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);
@@ -13536,6 +13567,7 @@ resolve_types (gfc_namespace *ns)
}
forall_flag = 0;
+ do_concurrent_flag = 0;
gfc_check_interfaces (ns);
gfc_traverse_ns (ns, resolve_values);
@@ -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;
@@ -3829,6 +3829,15 @@ tree gfc_trans_forall (gfc_code * code)
}
+/* Translate the DO CONCURRENT construct. */
+
+tree gfc_trans_do_concurrent (gfc_code * code)
+{
+ gfc_error ("Sorry, DO CONCURRENT at %L is not yet implemented", &(code->loc));
+ return NULL_TREE;
+}
+
+
/* 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
@@ -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);
@@ -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;
@@ -0,0 +1,67 @@
+! { 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
+
+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
Recently, I came across PR 44646, where I wrote a bit more than a year ago: "I have an embryonic patch for it". Well, I found it again, did some polishing - and here it is. This patch implements the parsing/diagnostic for "DO[,] CONCURRENT for-all-header", e.g. do concurrent (i = 1:5) A(i) = B(i) end do DO CONCURRENT allows the compiler to go through the loop in any order and also in parallel; some constraints help to avoid dependencies, but it is the duty of the programmer to ensure that the order does not matter. That's one difference to the FORALL construct; another is that one is allow to do much more in the DO CONCURRENT block than FORALL allows: Other loops, conditional jumps, ... TODO as follow up: - Replace "Sorry" by a real implementation in trans-stmt.c - Add documentation to gfc-internal.texi, update gfortran.texi (F2003 status) and the wiki - Try to make use of the constraints for the middle end (optimization, autoparallelization), if possible. - Optionally (-fdo-concurrent=...?), parallelize the loop (e.g. by adding OpenMP pragmas). Build and regtested on x86-64-linux. OK for the trunk? Tobias