* [Patch, Fortran] PR44646 - Add parser support for DO CONCURRENT
@ 2011-09-03 12:50 Tobias Burnus
2011-09-05 16:12 ` Tobias Burnus
0 siblings, 1 reply; 5+ messages in thread
From: Tobias Burnus @ 2011-09-03 12:50 UTC (permalink / raw)
To: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 1151 bytes --]
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
[-- Attachment #2: do_concurrent.diff --]
[-- Type: text/x-patch, Size: 38572 bytes --]
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.
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 18e2651..0ee2575 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 ad8b554..af2cd85 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/gfortran.h b/gcc/fortran/gfortran.h
index ac36d24..54e0b20 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 43aeb19..63410f8 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,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;
-}
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 9b11086..24d8960 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 b18056c..9e56b81 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 436c160..3877711 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. */
@@ -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);
diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c
index 572baaf..932c942 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 7d8b4e0..f811089 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -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
diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h
index 2d0faf1..caa4c98 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 4a71c43..764bdf4 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;
--- /dev/null 2011-09-03 12:56:10.495886960 +0200
+++ gcc/gcc/testsuite/gfortran.dg/do_concurrent_1.f90 2011-09-03 13:05:59.000000000 +0200
@@ -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
^ permalink raw reply [flat|nested] 5+ messages in thread
* Re: [Patch, Fortran] PR44646 - Add parser support for DO CONCURRENT
2011-09-03 12:50 [Patch, Fortran] PR44646 - Add parser support for DO CONCURRENT Tobias Burnus
@ 2011-09-05 16:12 ` Tobias Burnus
2011-09-08 1:31 ` Mikael Morin
2011-09-08 7:53 ` Thomas Koenig
0 siblings, 2 replies; 5+ messages in thread
From: Tobias Burnus @ 2011-09-05 16:12 UTC (permalink / raw)
To: gcc patches, gfortran
[-- Attachment #1: Type: text/plain, Size: 500 bytes --]
On 09/03/2011 02:49 PM, Tobias Burnus wrote:
> 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
(Side remark: do concurrent also supports a logical mask expression as
FORALL does.)
I have attached an updated version, which actually implements do
concurrent in trans-stmt.c. Additionally, "CYCLE" without a label did
not work.
> Build and regtested on x86-64-linux.
> OK for the trunk?
Tobias
[-- Attachment #2: do_concurrent-v2.diff --]
[-- Type: text/x-patch, Size: 41237 bytes --]
2011-09-06 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.
(gfc_trans_forall_1): Handle do concurrent.
* trans-stmt.h (gfc_trans_do_concurrent): New function prototype.
* trans.c (trans_code): Call it.
2011-09-06 Tobias Burnus <burnus@net-b.de>
PR fortran/44646
* gfortran.dg/do_concurrent_1.f90: New.
* gfortran.dg/do_concurrent_2.f90: New.
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 18e2651..0ee2575 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 ad8b554..af2cd85 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/gfortran.h b/gcc/fortran/gfortran.h
index ac36d24..54e0b20 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 43aeb19..4ea98b6 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,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,7 +2529,17 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op)
gfc_ascii_statement (st));
return MATCH_ERROR;
}
- else if ((sym && sym == p->sym) || (!sym && p->state == COMP_DO))
+ 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;
if (p == NULL)
@@ -2071,6 +2558,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 +2690,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 +2818,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 +2834,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 +3034,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 +3413,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 +3507,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 +3876,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 +4001,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 +5607,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;
-}
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 9b11086..24d8960 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 b18056c..9e56b81 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 436c160..3877711 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. */
@@ -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);
diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c
index 572baaf..932c942 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 7d8b4e0..1fdb059 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 2d0faf1..caa4c98 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 4a71c43..764bdf4 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;
--- /dev/null 2011-09-05 08:32:03.622741340 +0200
+++ gcc/gcc/testsuite/gfortran.dg/do_concurrent_1.f90 2011-09-05 16:44:56.000000000 +0200
@@ -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
--- /dev/null 2011-09-05 08:32:03.622741340 +0200
+++ gcc/gcc/testsuite/gfortran.dg/do_concurrent_2.f90 2011-09-05 17:07:18.000000000 +0200
@@ -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
^ permalink raw reply [flat|nested] 5+ messages in thread
* Re: [Patch, Fortran] PR44646 - Add parser support for DO CONCURRENT
2011-09-05 16:12 ` Tobias Burnus
@ 2011-09-08 1:31 ` Mikael Morin
2011-09-08 7:59 ` Tobias Burnus
2011-09-08 7:53 ` Thomas Koenig
1 sibling, 1 reply; 5+ messages in thread
From: Mikael Morin @ 2011-09-08 1:31 UTC (permalink / raw)
To: fortran; +Cc: Tobias Burnus, gcc patches
On Monday 05 September 2011 18:11:47 Tobias Burnus wrote:
> On 09/03/2011 02:49 PM, Tobias Burnus wrote:
> > 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
>
> (Side remark: do concurrent also supports a logical mask expression as
> FORALL does.)
>
>
> I have attached an updated version, which actually implements do
> concurrent in trans-stmt.c. Additionally, "CYCLE" without a label did
> not work.
>
> > Build and regtested on x86-64-linux.
> > OK for the trunk?
Patch is basically OK. One comment below.
> diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
> index 436c160..3877711 100644
> --- a/gcc/fortran/resolve.c
> +++ b/gcc/fortran/resolve.c
> @@ -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;
> + }
You could distinguish between mask and block here, like it is done for forall
just above, or you could decide that mask is part of the do concurrent block
and keep the error message as is (it is more i18n/gettext friendly), in which
case you don't need to set do_concurrent_flag to 2 (hunk below).
I'm undecided about which is the better one.
> @@ -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;
Thanks for the patch
Mikael
^ permalink raw reply [flat|nested] 5+ messages in thread
* Re: [Patch, Fortran] PR44646 - Add parser support for DO CONCURRENT
2011-09-05 16:12 ` Tobias Burnus
2011-09-08 1:31 ` Mikael Morin
@ 2011-09-08 7:53 ` Thomas Koenig
1 sibling, 0 replies; 5+ messages in thread
From: Thomas Koenig @ 2011-09-08 7:53 UTC (permalink / raw)
To: Tobias Burnus; +Cc: gcc patches, gfortran
Hi Tobias,
> I have attached an updated version, which actually implements do
> concurrent in trans-stmt.c. Additionally, "CYCLE" without a label did
> not work.
I think you also need to add support to frontend-passes.c.
Regards
Thomas
^ permalink raw reply [flat|nested] 5+ messages in thread
* Re: [Patch, Fortran] PR44646 - Add parser support for DO CONCURRENT
2011-09-08 1:31 ` Mikael Morin
@ 2011-09-08 7:59 ` Tobias Burnus
0 siblings, 0 replies; 5+ messages in thread
From: Tobias Burnus @ 2011-09-08 7:59 UTC (permalink / raw)
To: Mikael Morin; +Cc: gcc patches, gfortran
Mikael Morin wrote:
> Patch is basically OK. One comment below.
>
>> diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
>> index 436c160..3877711 100644
>> --- a/gcc/fortran/resolve.c
>> +++ b/gcc/fortran/resolve.c
>> @@ -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");
>> + else if (do_concurrent_flag)
>> + gfc_error ("Reference to non-PURE function '%s' at %L inside a "
>> + "DO CONCURRENT block", name,&expr->where);
> You could distinguish between mask and block here, like it is done for forall
> just above
I have changed it to be in the line with FORALL.
I have also added EXEC_DO_CONCURRENT after EXEC_FORALL in
frontend-optimization.c as suggested by Thomas.
Committed as Rev. 178677.
Thanks for the thorough review!
Tobias
^ permalink raw reply [flat|nested] 5+ messages in thread
end of thread, other threads:[~2011-09-08 6:41 UTC | newest]
Thread overview: 5+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2011-09-03 12:50 [Patch, Fortran] PR44646 - Add parser support for DO CONCURRENT Tobias Burnus
2011-09-05 16:12 ` Tobias Burnus
2011-09-08 1:31 ` Mikael Morin
2011-09-08 7:59 ` Tobias Burnus
2011-09-08 7:53 ` Thomas Koenig
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).