This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [Patch, Fortran, 4.6] F2008 - first coarray patch
- From: Tobias Burnus <burnus at net-b dot de>
- To: gfortran <fortran at gcc dot gnu dot org>, gcc patches <gcc-patches at gcc dot gnu dot org>
- Date: Sun, 31 Jan 2010 12:57:58 +0100
- Subject: Re: [Patch, Fortran, 4.6] F2008 - first coarray patch
- References: <4B6014FD.1020306@net-b.de>
Hi all,
Tobias Burnus wrote:
> The attached patch implements CRITICAL block, ALL STOP, SYNC
> ALL/MEMORY/IMAGES, and num_images.
>
I forgot a check for "C1288 A pure subprogram shall not contain an image
control statement.", which I now added in match.c's sync_statement and
match_critical (and in the coarray_3.f90 test case). Otherwise, the
patch is unchanged.
OK for the 4.6 trunk?
Tobias
gcc/fortran/decl.c | 6
gcc/fortran/dump-parse-tree.c | 57 +++++++
gcc/fortran/gfortran.h | 10 -
gcc/fortran/intrinsic.c | 3
gcc/fortran/intrinsic.h | 1
gcc/fortran/intrinsic.texi | 44 +++++
gcc/fortran/match.c | 255 +++++++++++++++++++++++++++++++-
gcc/fortran/match.h | 5
gcc/fortran/parse.c | 98 ++++++++++++
gcc/fortran/parse.h | 2
gcc/fortran/resolve.c | 67 ++++++++
gcc/fortran/simplify.c | 12 +
gcc/fortran/st.c | 5
gcc/fortran/trans-decl.c | 8 +
gcc/fortran/trans-stmt.c | 64 +++++++-
gcc/fortran/trans-stmt.h | 4
gcc/fortran/trans.c | 13 +
gcc/fortran/trans.h | 1
gcc/testsuite/gfortran.dg/coarray_1.f90 | 18 ++
gcc/testsuite/gfortran.dg/coarray_2.f90 | 46 ++++++
gcc/testsuite/gfortran.dg/coarray_3.f90 | 82 ++++++++++
libgfortran/gfortran.map | 5
libgfortran/runtime/stop.c | 19 ++
23 files changed, 786 insertions(+), 20 deletions(-)
2010-01-31 Tobias Burnus <burnus@net-b.de>
PR fortran/39997
* intrinsic.c (add_functions): Add num_images.
* decl.c (gfc_match_end): Handle END CRITICAL.
* intrinsic.h (gfc_simplify_num_images): Add prototype.
* dump-parse-tree.c (show_code_node): Dump CRITICAL, ALL STOP,
and SYNC.
* gfortran.h (gfc_statement): Add enum items for those.
(gfc_exec_op) Ditto.
(gfc_isym_id): Add num_images.
* trans-stmt.c (gfc_trans_stop): Handle ALL STOP.
(gfc_trans_sync,gfc_trans_critical): New functions.
* trans-stmt.h (gfc_trans_stop,gfc_trans_sync,
gfc_trans_critical): Add/update prototypes.
* trans.c (gfc_trans_code): Handle CRITICAL, ALL STOP,
and SYNC statements.
* trans.h (gfor_fndecl_all_stop_string) Add variable.
* resolve.c (resolve_sync): Add function.
(gfc_resolve_blocks): Handle CRITICAL.
(resolve_code): Handle CRITICAL, ALL STOP,
(resolve_branch): Add CRITICAL constraint check.
and SYNC statements.
* st.c (gfc_free_statement): Add new statements.
* trans-decl.c (gfor_fndecl_all_stop_string): Global variable.
(gfc_build_builtin_function_decls): Initialize it.
* match.c (gfc_match_if): Handle ALL STOP and SYNC.
(gfc_match_critical, gfc_match_all_stop, sync_statement,
gfc_match_sync_all, gfc_match_sync_images, gfc_match_sync_memory):
New functions.
(match_exit_cycle): Handle CRITICAL constraint.
(gfc_match_stopcode): Handle ALL STOP.
* match.h (gfc_match_critical, gfc_match_all_stop,
gfc_match_sync_all, gfc_match_sync_images,
gfc_match_sync_memory): Add prototype.
* parse.c (decode_statement, gfc_ascii_statement,
parse_executable): Handle new statements.
(parse_critical_block): New function.
* parse.h (gfc_compile_state): Add COMP_CRITICAL.
* intrinsic.texi (num_images): Document new function.
* simplify.c (gfc_simplify_num_images): Add function.
2010-01-31 Tobias Burnus <burnus@net-b.de>
PR fortran/39997
* gfortran.dg/coarray_1.f90: New test.
* gfortran.dg/coarray_2.f90: New test.
* gfortran.dg/coarray_3.f90: New test.
2010-01-31 Tobias Burnus <burnus@net-b.de>
PR fortran/39997
* runtime/stop.c (all_stop_string): New function.
* gfortran.map (_gfortran_all_stop_string): Add.
Index: gcc/fortran/intrinsic.c
===================================================================
--- gcc/fortran/intrinsic.c (revision 156274)
+++ gcc/fortran/intrinsic.c (working copy)
@@ -2220,6 +2220,9 @@ add_functions (void)
make_generic ("null", GFC_ISYM_NULL, GFC_STD_F95);
+ add_sym_0 ("num_images", GFC_ISYM_NUMIMAGES, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008,
+ NULL, gfc_simplify_num_images, NULL);
+
add_sym_3 ("pack", GFC_ISYM_PACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
gfc_check_pack, gfc_simplify_pack, gfc_resolve_pack,
ar, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED,
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c (revision 156274)
+++ gcc/fortran/decl.c (working copy)
@@ -5471,6 +5471,12 @@ gfc_match_end (gfc_statement *st)
eos_ok = 0;
break;
+ case COMP_CRITICAL:
+ *st = ST_END_CRITICAL;
+ target = " critical";
+ eos_ok = 0;
+ break;
+
case COMP_SELECT:
case COMP_SELECT_TYPE:
*st = ST_END_SELECT;
Index: gcc/fortran/intrinsic.h
===================================================================
--- gcc/fortran/intrinsic.h (revision 156274)
+++ gcc/fortran/intrinsic.h (working copy)
@@ -297,6 +297,7 @@ gfc_expr *gfc_simplify_nearest (gfc_expr
gfc_expr *gfc_simplify_new_line (gfc_expr *);
gfc_expr *gfc_simplify_nint (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_null (gfc_expr *);
+gfc_expr *gfc_simplify_num_images (void);
gfc_expr *gfc_simplify_idnint (gfc_expr *);
gfc_expr *gfc_simplify_not (gfc_expr *);
gfc_expr *gfc_simplify_or (gfc_expr *, gfc_expr *);
Index: gcc/fortran/dump-parse-tree.c
===================================================================
--- gcc/fortran/dump-parse-tree.c (revision 156274)
+++ gcc/fortran/dump-parse-tree.c (working copy)
@@ -1273,6 +1273,10 @@ show_code_node (int level, gfc_code *c)
break;
+ case EXEC_ALL_STOP:
+ fputs ("ALL ", dumpfile);
+ /* Fall through. */
+
case EXEC_STOP:
fputs ("STOP ", dumpfile);
@@ -1283,6 +1287,52 @@ show_code_node (int level, gfc_code *c)
break;
+ case EXEC_SYNC_ALL:
+ fputs ("SYNC ALL ", dumpfile);
+ if (c->expr2 != NULL)
+ {
+ fputs (" stat=", dumpfile);
+ show_expr (c->expr2);
+ }
+ if (c->expr3 != NULL)
+ {
+ fputs (" errmsg=", dumpfile);
+ show_expr (c->expr3);
+ }
+ break;
+
+ case EXEC_SYNC_MEMORY:
+ fputs ("SYNC MEMORY ", dumpfile);
+ if (c->expr2 != NULL)
+ {
+ fputs (" stat=", dumpfile);
+ show_expr (c->expr2);
+ }
+ if (c->expr3 != NULL)
+ {
+ fputs (" errmsg=", dumpfile);
+ show_expr (c->expr3);
+ }
+ break;
+
+ case EXEC_SYNC_IMAGES:
+ fputs ("SYNC IMAGES image-set=", dumpfile);
+ if (c->expr1 != NULL)
+ show_expr (c->expr1);
+ else
+ fputs ("* ", dumpfile);
+ if (c->expr2 != NULL)
+ {
+ fputs (" stat=", dumpfile);
+ show_expr (c->expr2);
+ }
+ if (c->expr3 != NULL)
+ {
+ fputs (" errmsg=", dumpfile);
+ show_expr (c->expr3);
+ }
+ break;
+
case EXEC_ARITHMETIC_IF:
fputs ("IF ", dumpfile);
show_expr (c->expr1);
@@ -1400,6 +1450,13 @@ show_code_node (int level, gfc_code *c)
fputs ("END FORALL", dumpfile);
break;
+ case EXEC_CRITICAL:
+ fputs ("CRITICAL\n", dumpfile);
+ show_code (level + 1, c->block->next);
+ code_indent (level, 0);
+ fputs ("END CRITICAL", dumpfile);
+ break;
+
case EXEC_DO:
fputs ("DO ", dumpfile);
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 156274)
+++ gcc/fortran/gfortran.h (working copy)
@@ -205,7 +205,7 @@ arith;
/* Statements. */
typedef enum
{
- ST_ARITHMETIC_IF, ST_ALLOCATE, ST_ATTR_DECL, ST_BACKSPACE,
+ ST_ARITHMETIC_IF, ST_ALL_STOP, ST_ALLOCATE, ST_ATTR_DECL, ST_BACKSPACE,
ST_BLOCK, ST_BLOCK_DATA,
ST_CALL, ST_CASE, ST_CLOSE, ST_COMMON, ST_CONTINUE, ST_CONTAINS, ST_CYCLE,
ST_DATA, ST_DATA_DECL, ST_DEALLOCATE, ST_DO, ST_ELSE, ST_ELSEIF,
@@ -215,7 +215,7 @@ typedef enum
ST_END_SUBROUTINE, ST_END_WHERE, ST_END_TYPE, ST_ENTRY, ST_EQUIVALENCE,
ST_EXIT, ST_FORALL, ST_FORALL_BLOCK, ST_FORMAT, ST_FUNCTION, ST_GOTO,
ST_IF_BLOCK, ST_IMPLICIT, ST_IMPLICIT_NONE, ST_IMPORT,
- ST_INQUIRE, ST_INTERFACE,
+ ST_INQUIRE, ST_INTERFACE, ST_SYNC_ALL, ST_SYNC_MEMORY, ST_SYNC_IMAGES,
ST_PARAMETER, ST_MODULE, ST_MODULE_PROC, ST_NAMELIST, ST_NULLIFY, ST_OPEN,
ST_PAUSE, ST_PRIVATE, ST_PROGRAM, ST_PUBLIC, ST_READ, ST_RETURN, ST_REWIND,
ST_STOP, ST_SUBROUTINE, ST_TYPE, ST_USE, ST_WHERE_BLOCK, ST_WHERE, ST_WAIT,
@@ -230,7 +230,7 @@ typedef enum
ST_OMP_PARALLEL, ST_OMP_PARALLEL_DO, ST_OMP_PARALLEL_SECTIONS,
ST_OMP_PARALLEL_WORKSHARE, ST_OMP_SECTIONS, ST_OMP_SECTION, ST_OMP_SINGLE,
ST_OMP_THREADPRIVATE, ST_OMP_WORKSHARE, ST_OMP_TASK, ST_OMP_END_TASK,
- ST_OMP_TASKWAIT, ST_PROCEDURE, ST_GENERIC,
+ ST_OMP_TASKWAIT, ST_PROCEDURE, ST_GENERIC, ST_CRITICAL, ST_END_CRITICAL,
ST_GET_FCN_CHARACTERISTICS, ST_NONE
}
gfc_statement;
@@ -461,6 +461,7 @@ enum gfc_isym_id
GFC_ISYM_NINT,
GFC_ISYM_NOT,
GFC_ISYM_NULL,
+ GFC_ISYM_NUMIMAGES,
GFC_ISYM_OR,
GFC_ISYM_PACK,
GFC_ISYM_PERROR,
@@ -1975,12 +1976,13 @@ gfc_forall_iterator;
typedef enum
{
EXEC_NOP = 1, EXEC_END_BLOCK, EXEC_ASSIGN, EXEC_LABEL_ASSIGN,
- EXEC_POINTER_ASSIGN,
+ EXEC_POINTER_ASSIGN, EXEC_ALL_STOP, EXEC_CRITICAL,
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_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,
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (revision 156274)
+++ gcc/fortran/trans-stmt.c (working copy)
@@ -576,7 +576,7 @@ gfc_trans_pause (gfc_code * code)
to a runtime library call. */
tree
-gfc_trans_stop (gfc_code * code)
+gfc_trans_stop (gfc_code *code, bool all_stop)
{
tree gfc_int4_type_node = gfc_get_int_type (4);
gfc_se se;
@@ -586,7 +586,6 @@ gfc_trans_stop (gfc_code * code)
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
-
if (code->expr1 == NULL)
{
tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code);
@@ -597,8 +596,9 @@ gfc_trans_stop (gfc_code * code)
{
gfc_conv_expr_reference (&se, code->expr1);
tmp = build_call_expr_loc (input_location,
- gfor_fndecl_stop_string, 2,
- se.expr, se.string_length);
+ all_stop ? gfor_fndecl_all_stop_string
+ : gfor_fndecl_stop_string,
+ 2, se.expr, se.string_length);
}
gfc_add_expr_to_block (&se.pre, tmp);
@@ -609,6 +609,47 @@ gfc_trans_stop (gfc_code * code)
}
+tree
+gfc_trans_sync (gfc_code *code, gfc_exec_op type __attribute__ ((unused)))
+{
+ gfc_se se;
+
+ if ((code->expr1 && gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) || code->expr2)
+ {
+ gfc_init_se (&se, NULL);
+ gfc_start_block (&se.pre);
+ }
+
+ /* Check SYNC IMAGES(imageset) for valid image index.
+ FIXME: Add a check for image-set arrays. */
+ if (code->expr1 && gfc_option.rtcheck & GFC_RTCHECK_BOUNDS
+ && code->expr1->rank == 0)
+ {
+ tree cond;
+ gfc_conv_expr (&se, code->expr1);
+ cond = fold_build2 (NE_EXPR, boolean_type_node, se.expr,
+ build_int_cst (TREE_TYPE (se.expr), 1));
+ gfc_trans_runtime_check (true, false, cond, &se.pre,
+ &code->expr1->where, "Invalid image number "
+ "%d in SYNC IMAGES",
+ fold_convert (integer_type_node, se.expr));
+ }
+
+ /* If STAT is present, set it to zero. */
+ if (code->expr2)
+ {
+ gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
+ gfc_conv_expr (&se, code->expr2);
+ gfc_add_modify (&se.pre, se.expr, build_int_cst (TREE_TYPE (se.expr), 0));
+ }
+
+ if ((code->expr1 && gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) || code->expr2)
+ return gfc_finish_block (&se.pre);
+
+ return NULL_TREE;
+}
+
+
/* Generate GENERIC for the IF construct. This function also deals with
the simple IF statement, because the front end translates the IF
statement into an IF construct.
@@ -769,6 +810,21 @@ gfc_trans_arithmetic_if (gfc_code * code
}
+/* Translate a CRITICAL block. */
+tree
+gfc_trans_critical (gfc_code *code)
+{
+ stmtblock_t block;
+ tree tmp;
+
+ gfc_start_block (&block);
+ tmp = gfc_trans_code (code->block->next);
+ gfc_add_expr_to_block (&block, tmp);
+
+ return gfc_finish_block (&block);
+}
+
+
/* Translate a BLOCK construct. This is basically what we would do for a
procedure body. */
Index: gcc/fortran/trans-stmt.h
===================================================================
--- gcc/fortran/trans-stmt.h (revision 156274)
+++ gcc/fortran/trans-stmt.h (working copy)
@@ -33,13 +33,14 @@ tree gfc_trans_class_assign (gfc_code *c
/* trans-stmt.c */
tree gfc_trans_cycle (gfc_code *);
+tree gfc_trans_critical (gfc_code *);
tree gfc_trans_exit (gfc_code *);
tree gfc_trans_label_assign (gfc_code *);
tree gfc_trans_label_here (gfc_code *);
tree gfc_trans_goto (gfc_code *);
tree gfc_trans_entry (gfc_code *);
tree gfc_trans_pause (gfc_code *);
-tree gfc_trans_stop (gfc_code *);
+tree gfc_trans_stop (gfc_code *, bool);
tree gfc_trans_call (gfc_code *, bool, tree, tree, bool);
tree gfc_trans_return (gfc_code *);
tree gfc_trans_if (gfc_code *);
@@ -48,6 +49,7 @@ tree gfc_trans_block_construct (gfc_code
tree gfc_trans_do (gfc_code *);
tree gfc_trans_do_while (gfc_code *);
tree gfc_trans_select (gfc_code *);
+tree gfc_trans_sync (gfc_code *, gfc_exec_op);
tree gfc_trans_forall (gfc_code *);
tree gfc_trans_where (gfc_code *);
tree gfc_trans_allocate (gfc_code *);
Index: gcc/fortran/trans.c
===================================================================
--- gcc/fortran/trans.c (revision 156274)
+++ gcc/fortran/trans.c (working copy)
@@ -1105,6 +1105,10 @@ gfc_trans_code (gfc_code * code)
res = NULL_TREE;
break;
+ case EXEC_CRITICAL:
+ res = gfc_trans_critical (code);
+ break;
+
case EXEC_CYCLE:
res = gfc_trans_cycle (code);
break;
@@ -1126,7 +1130,8 @@ gfc_trans_code (gfc_code * code)
break;
case EXEC_STOP:
- res = gfc_trans_stop (code);
+ case EXEC_ALL_STOP:
+ res = gfc_trans_stop (code, code->op == EXEC_ALL_STOP);
break;
case EXEC_CALL:
@@ -1191,6 +1196,12 @@ gfc_trans_code (gfc_code * code)
res = gfc_trans_flush (code);
break;
+ case EXEC_SYNC_ALL:
+ case EXEC_SYNC_IMAGES:
+ case EXEC_SYNC_MEMORY:
+ res = gfc_trans_sync (code, code->op);
+ break;
+
case EXEC_FORALL:
res = gfc_trans_forall (code);
break;
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h (revision 156274)
+++ gcc/fortran/trans.h (working copy)
@@ -533,6 +533,7 @@ extern GTY(()) tree gfor_fndecl_pause_nu
extern GTY(()) tree gfor_fndecl_pause_string;
extern GTY(()) tree gfor_fndecl_stop_numeric;
extern GTY(()) tree gfor_fndecl_stop_string;
+extern GTY(()) tree gfor_fndecl_all_stop_string;
extern GTY(()) tree gfor_fndecl_runtime_error;
extern GTY(()) tree gfor_fndecl_runtime_error_at;
extern GTY(()) tree gfor_fndecl_runtime_warning_at;
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 156274)
+++ gcc/fortran/resolve.c (working copy)
@@ -7262,6 +7262,48 @@ find_reachable_labels (gfc_code *block)
}
}
+
+static void
+resolve_sync (gfc_code *code)
+{
+ /* Check imageset. The * case matches expr1 == NULL. */
+ if (code->expr1)
+ {
+ if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1)
+ gfc_error ("Imageset argument at %L must be a scalar or rank-1 "
+ "INTEGER expression", &code->expr1->where);
+ if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0
+ && mpz_cmp_si (code->expr1->value.integer, 1) < 0)
+ gfc_error ("Imageset argument at %L must between 1 and num_images()",
+ &code->expr1->where);
+ else if (code->expr1->expr_type == EXPR_ARRAY
+ && gfc_simplify_expr (code->expr1, 0) == SUCCESS)
+ {
+ gfc_constructor *cons;
+ for (cons = code->expr1->value.constructor; cons; cons = cons->next)
+ if (cons->expr->expr_type == EXPR_CONSTANT
+ && mpz_cmp_si (cons->expr->value.integer, 1) < 0)
+ gfc_error ("Imageset argument at %L must between 1 and "
+ "num_images()", &cons->expr->where);
+ }
+ }
+
+ /* Check STAT. */
+ if (code->expr2
+ && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0
+ || code->expr2->expr_type != EXPR_VARIABLE))
+ gfc_error ("STAT= argument at %L must be a scalar INTEGER variable",
+ &code->expr2->where);
+
+ /* Check ERRMSG. */
+ if (code->expr3
+ && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0
+ || code->expr3->expr_type != EXPR_VARIABLE))
+ gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable",
+ &code->expr3->where);
+}
+
+
/* Given a branch to a label, see if the branch is conforming.
The code node describes where the branch is located. */
@@ -7302,7 +7344,15 @@ resolve_branch (gfc_st_label *label, gfc
the bitmap reachable_labels. */
if (bitmap_bit_p (cs_base->reachable_labels, label->value))
- return;
+ {
+ for (stack = cs_base; stack; stack = stack->prev)
+ if (stack->current->op == EXEC_CRITICAL
+ && bitmap_bit_p (stack->prev->reachable_labels, label->value))
+ gfc_error ("GOTO statement at %L leaves CRITCAL block for label at "
+ "%L", &code->loc, &label->where);
+
+ return;
+ }
/* Step four: If we haven't found the label in the bitmap, it may
still be the label of the END of the enclosing block, in which
@@ -7314,7 +7364,13 @@ resolve_branch (gfc_st_label *label, gfc
if (stack)
{
+ code_stack *stack2;
gcc_assert (stack->current->next->op == EXEC_END_BLOCK);
+ for (stack2 = cs_base; stack2 != stack; stack2 = stack2->prev)
+ if (stack2->current->op == EXEC_CRITICAL)
+ gfc_error ("GOTO statement at %L leaves CRITCAL block for label at "
+ "%L", &code->loc, &label->where);
+
return;
}
@@ -7735,6 +7791,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_nam
case EXEC_FORALL:
case EXEC_DO:
case EXEC_DO_WHILE:
+ case EXEC_CRITICAL:
case EXEC_READ:
case EXEC_WRITE:
case EXEC_IOLENGTH:
@@ -8009,10 +8066,18 @@ resolve_code (gfc_code *code, gfc_namesp
case EXEC_CYCLE:
case EXEC_PAUSE:
case EXEC_STOP:
+ case EXEC_ALL_STOP:
case EXEC_EXIT:
case EXEC_CONTINUE:
case EXEC_DT_END:
case EXEC_ASSIGN_CALL:
+ case EXEC_CRITICAL:
+ break;
+
+ case EXEC_SYNC_ALL:
+ case EXEC_SYNC_IMAGES:
+ case EXEC_SYNC_MEMORY:
+ resolve_sync (code);
break;
case EXEC_ENTRY:
Index: gcc/fortran/st.c
===================================================================
--- gcc/fortran/st.c (revision 156274)
+++ gcc/fortran/st.c (working copy)
@@ -98,6 +98,7 @@ gfc_free_statement (gfc_code *p)
case EXEC_IF:
case EXEC_PAUSE:
case EXEC_STOP:
+ case EXEC_ALL_STOP:
case EXEC_EXIT:
case EXEC_WHERE:
case EXEC_IOLENGTH:
@@ -108,6 +109,10 @@ gfc_free_statement (gfc_code *p)
case EXEC_LABEL_ASSIGN:
case EXEC_ENTRY:
case EXEC_ARITHMETIC_IF:
+ case EXEC_CRITICAL:
+ case EXEC_SYNC_ALL:
+ case EXEC_SYNC_IMAGES:
+ case EXEC_SYNC_MEMORY:
break;
case EXEC_BLOCK:
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (revision 156274)
+++ gcc/fortran/trans-decl.c (working copy)
@@ -85,6 +85,7 @@ tree gfor_fndecl_pause_numeric;
tree gfor_fndecl_pause_string;
tree gfor_fndecl_stop_numeric;
tree gfor_fndecl_stop_string;
+tree gfor_fndecl_all_stop_string;
tree gfor_fndecl_runtime_error;
tree gfor_fndecl_runtime_error_at;
tree gfor_fndecl_runtime_warning_at;
@@ -2718,6 +2719,13 @@ gfc_build_builtin_function_decls (void)
/* Stop doesn't return. */
TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
+ gfor_fndecl_all_stop_string =
+ gfc_build_library_function_decl (get_identifier (PREFIX("all_stop_string")),
+ void_type_node, 2, pchar_type_node,
+ gfc_int4_type_node);
+ /* ALL STOP doesn't return. */
+ TREE_THIS_VOLATILE (gfor_fndecl_all_stop_string) = 1;
+
gfor_fndecl_pause_numeric =
gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
void_type_node, 1, gfc_int4_type_node);
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c (Revision 156398)
+++ gcc/fortran/match.c (Arbeitskopie)
@@ -1538,6 +1538,7 @@ gfc_match_if (gfc_statement *if_type)
gfc_clear_error ();
+ match ("all stop", gfc_match_all_stop, ST_ALL_STOP)
match ("allocate", gfc_match_allocate, ST_ALLOCATE)
match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
match ("backspace", gfc_match_backspace, ST_BACKSPACE)
@@ -1562,6 +1563,9 @@ gfc_match_if (gfc_statement *if_type)
match ("rewind", gfc_match_rewind, ST_REWIND)
match ("stop", gfc_match_stop, ST_STOP)
match ("wait", gfc_match_wait, ST_WAIT)
+ match ("sync all", gfc_match_sync_all, ST_SYNC_CALL);
+ match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
+ match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
match ("where", match_simple_where, ST_WHERE)
match ("write", gfc_match_write, ST_WRITE)
@@ -1708,6 +1712,53 @@ gfc_free_iterator (gfc_iterator *iter, i
}
+/* Match a CRITICAL statement. */
+match
+gfc_match_critical (void)
+{
+ gfc_st_label *label = NULL;
+
+ if (gfc_match_label () == MATCH_ERROR)
+ return MATCH_ERROR;
+
+ if (gfc_match (" critical") != MATCH_YES)
+ return MATCH_NO;
+
+ if (gfc_match_st_label (&label) == MATCH_ERROR)
+ return MATCH_ERROR;
+
+ if (gfc_match_eos () != MATCH_YES)
+ {
+ gfc_syntax_error (ST_CRITICAL);
+ return MATCH_ERROR;
+ }
+
+ if (gfc_pure (NULL))
+ {
+ gfc_error ("Image control statement CRITICAL at %C in PURE procedure");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CRITICAL statement at %C")
+ == FAILURE)
+ return MATCH_ERROR;
+
+ if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
+ {
+ gfc_error ("Nested CRITICAL block at %C");
+ return MATCH_ERROR;
+ }
+
+ new_st.op = EXEC_CRITICAL;
+
+ if (label != NULL
+ && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
+ return MATCH_ERROR;
+
+ return MATCH_YES;
+}
+
+
/* Match a BLOCK statement. */
match
@@ -1871,6 +1922,12 @@ match_exit_cycle (gfc_statement st, gfc_
break;
else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
o = p;
+ else if (p-> state == COMP_CRITICAL)
+ {
+ gfc_error("%s statement at %C leaves CRITICAL block",
+ gfc_ascii_statement (st));
+ return MATCH_ERROR;
+ }
if (p == NULL)
{
@@ -1930,7 +1987,7 @@ gfc_match_cycle (void)
}
-/* Match a number or character constant after a STOP or PAUSE statement. */
+/* Match a number or character constant after an (ALL) STOP or PAUSE statement. */
static match
gfc_match_stopcode (gfc_statement st)
@@ -1978,7 +2035,16 @@ gfc_match_stopcode (gfc_statement st)
goto cleanup;
}
- new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
+ if (st == ST_STOP && gfc_find_state (COMP_CRITICAL) == SUCCESS)
+ {
+ gfc_error ("Image control statement STOP at %C in CRITICAL block");
+ return MATCH_ERROR;
+ }
+
+ if (st == ST_STOP || st == ST_ALL_STOP)
+ new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_ALL_STOP;
+ else
+ new_st.op = EXEC_PAUSE;
new_st.expr1 = e;
new_st.ext.stop_code = stop_code;
@@ -2022,6 +2088,184 @@ gfc_match_stop (void)
}
+/* Match the ALL STOP statement. */
+
+match
+gfc_match_all_stop (void)
+{
+ if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: ALL STOP statement at %C")
+ == FAILURE)
+ return MATCH_ERROR;
+
+ return gfc_match_stopcode (ST_ALL_STOP);
+}
+
+
+/* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
+ SYNC ALL [(sync-stat-list)]
+ SYNC MEMORY [(sync-stat-list)]
+ SYNC IMAGES (image-set [, sync-stat-list] )
+ with sync-stat is int-expr or *. */
+
+static match
+sync_statement (gfc_statement st)
+{
+ match m;
+ gfc_expr *tmp, *imageset, *stat, *errmsg;
+ bool saw_stat, saw_errmsg;
+
+ tmp = imageset = stat = errmsg = NULL;
+ saw_stat = saw_errmsg = false;
+
+ if (gfc_pure (NULL))
+ {
+ gfc_error ("Image control statement SYNC at %C in PURE procedure");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SYNC statement at %C")
+ == FAILURE)
+ return MATCH_ERROR;
+
+ if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
+ {
+ gfc_error ("Image control statement SYNC at %C in CRITICAL block");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match_eos () == MATCH_YES)
+ {
+ if (st == ST_SYNC_IMAGES)
+ goto syntax;
+ goto done;
+ }
+
+ if (gfc_match_char ('(') != MATCH_YES)
+ goto syntax;
+
+ if (st == ST_SYNC_IMAGES)
+ {
+ /* Denote '*' as imageset == NULL. */
+ m =gfc_match_char ('*');
+ if (m == MATCH_ERROR)
+ goto syntax;
+ if (m == MATCH_NO)
+ {
+ if (gfc_match ("%e", &imageset) != MATCH_YES)
+ goto syntax;
+ }
+ m = gfc_match_char (',');
+ if (m == MATCH_ERROR)
+ goto syntax;
+ if (m == MATCH_NO)
+ {
+ m = gfc_match_char (')');
+ if (m == MATCH_YES)
+ goto done;
+ goto syntax;
+ }
+ }
+
+ for (;;)
+ {
+ m = gfc_match (" stat = %v", &tmp);
+ if (m == MATCH_ERROR)
+ goto syntax;
+ if (m == MATCH_YES)
+ {
+ if (saw_stat)
+ {
+ gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
+ goto cleanup;
+ }
+ stat = tmp;
+ saw_stat = true;
+
+ if (gfc_match_char (',') == MATCH_YES)
+ continue;
+ }
+
+ m = gfc_match (" errmsg = %v", &tmp);
+ if (m == MATCH_ERROR)
+ goto syntax;
+ if (m == MATCH_YES)
+ {
+ if (saw_errmsg)
+ {
+ gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
+ goto cleanup;
+ }
+ errmsg = tmp;
+ saw_errmsg = true;
+
+ if (gfc_match_char (',') == MATCH_YES)
+ continue;
+ }
+
+ gfc_gobble_whitespace ();
+
+ if (gfc_peek_char () == ')')
+ break;
+
+ goto syntax;
+ }
+
+ if (gfc_match (" )%t") != MATCH_YES)
+ goto syntax;
+
+done:
+ if (st == ST_SYNC_ALL)
+ new_st.op = EXEC_SYNC_ALL;
+ else if (st == ST_SYNC_IMAGES)
+ new_st.op = EXEC_SYNC_IMAGES;
+ else
+ new_st.op = EXEC_SYNC_MEMORY;
+ new_st.expr1 = imageset;
+ new_st.expr2 = stat;
+ new_st.expr3 = errmsg;
+
+ return MATCH_YES;
+
+syntax:
+ gfc_syntax_error (st);
+
+cleanup:
+ gfc_free_expr (tmp);
+ gfc_free_expr (imageset);
+ gfc_free_expr (stat);
+ gfc_free_expr (errmsg);
+
+ return MATCH_ERROR;
+}
+
+
+/* Match SYNC ALL statement. */
+
+match
+gfc_match_sync_all (void)
+{
+ return sync_statement (ST_SYNC_ALL);
+}
+
+
+/* Match SYNC IMAGES statement. */
+
+match
+gfc_match_sync_images (void)
+{
+ return sync_statement (ST_SYNC_IMAGES);
+}
+
+
+/* Match SYNC MEMORY statement. */
+
+match
+gfc_match_sync_memory (void)
+{
+ return sync_statement (ST_SYNC_MEMORY);
+}
+
+
/* Match a CONTINUE statement. */
match
@@ -2850,6 +3094,13 @@ gfc_match_return (void)
gfc_compile_state s;
e = NULL;
+
+ if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
+ {
+ gfc_error ("Image control statement RETURN at %C in CRITICAL block");
+ return MATCH_ERROR;
+ }
+
if (gfc_match_eos () == MATCH_YES)
goto done;
Index: gcc/fortran/match.h
===================================================================
--- gcc/fortran/match.h (revision 156274)
+++ gcc/fortran/match.h (working copy)
@@ -69,15 +69,20 @@ match gfc_match_assignment (void);
match gfc_match_if (gfc_statement *);
match gfc_match_else (void);
match gfc_match_elseif (void);
+match gfc_match_critical (void);
match gfc_match_block (void);
match gfc_match_do (void);
match gfc_match_cycle (void);
match gfc_match_exit (void);
match gfc_match_pause (void);
match gfc_match_stop (void);
+match gfc_match_all_stop (void);
match gfc_match_continue (void);
match gfc_match_assign (void);
match gfc_match_goto (void);
+match gfc_match_sync_all (void);
+match gfc_match_sync_images (void);
+match gfc_match_sync_memory (void);
match gfc_match_allocate (void);
match gfc_match_nullify (void);
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c (revision 156274)
+++ gcc/fortran/parse.c (working copy)
@@ -291,9 +291,9 @@ decode_statement (void)
gfc_undo_symbols ();
gfc_current_locus = old_locus;
- /* Check for the IF, DO, SELECT, WHERE, FORALL and BLOCK statements, which
- might begin with a block label. The match functions for these
- statements are unusual in that their keyword is not seen before
+ /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, and BLOCK
+ statements, which might begin with a block label. The match functions for
+ these statements are unusual in that their keyword is not seen before
the matcher is called. */
if (gfc_match_if (&st) == MATCH_YES)
@@ -311,8 +311,9 @@ decode_statement (void)
gfc_undo_symbols ();
gfc_current_locus = old_locus;
- match (NULL, gfc_match_block, ST_BLOCK);
match (NULL, gfc_match_do, ST_DO);
+ match (NULL, gfc_match_block, ST_BLOCK);
+ match (NULL, gfc_match_critical, ST_CRITICAL);
match (NULL, gfc_match_select, ST_SELECT_CASE);
match (NULL, gfc_match_select_type, ST_SELECT_TYPE);
@@ -329,6 +330,7 @@ decode_statement (void)
ST_INTERFACE);
match ("allocate", gfc_match_allocate, ST_ALLOCATE);
match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
+ match ("all stop", gfc_match_all_stop, ST_ALL_STOP);
match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT);
match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
break;
@@ -432,6 +434,9 @@ decode_statement (void)
match ("sequence", gfc_match_eos, ST_SEQUENCE);
match ("stop", gfc_match_stop, ST_STOP);
match ("save", gfc_match_save, ST_ATTR_DECL);
+ match ("sync all", gfc_match_sync_all, ST_SYNC_ALL);
+ match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
+ match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
break;
case 't':
@@ -936,7 +941,8 @@ next_statement (void)
case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
- case ST_OMP_BARRIER: case ST_OMP_TASKWAIT
+ case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_ALL_STOP: \
+ case ST_SYNC_ALL: case ST_SYNC_IMAGES: case ST_SYNC_MEMORY
/* Statements that mark other executable statements. */
@@ -948,7 +954,7 @@ next_statement (void)
case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
- case ST_OMP_TASK
+ case ST_OMP_TASK: case ST_CRITICAL
/* Declaration statements */
@@ -1146,6 +1152,9 @@ gfc_ascii_statement (gfc_statement st)
case ST_ALLOCATE:
p = "ALLOCATE";
break;
+ case ST_ALL_STOP:
+ p = "ALL STOP";
+ break;
case ST_ATTR_DECL:
p = _("attribute declaration");
break;
@@ -1176,6 +1185,9 @@ gfc_ascii_statement (gfc_statement st)
case ST_CONTAINS:
p = "CONTAINS";
break;
+ case ST_CRITICAL:
+ p = "CRITICAL";
+ break;
case ST_CYCLE:
p = "CYCLE";
break;
@@ -1209,6 +1221,9 @@ gfc_ascii_statement (gfc_statement st)
case ST_END_BLOCK_DATA:
p = "END BLOCK DATA";
break;
+ case ST_END_CRITICAL:
+ p = "END CRITICAL";
+ break;
case ST_ENDDO:
p = "END DO";
break;
@@ -1339,6 +1354,15 @@ gfc_ascii_statement (gfc_statement st)
case ST_STOP:
p = "STOP";
break;
+ case ST_SYNC_ALL:
+ p = "SYNC ALL";
+ break;
+ case ST_SYNC_IMAGES:
+ p = "SYNC IMAGES";
+ break;
+ case ST_SYNC_MEMORY:
+ p = "SYNC MEMORY";
+ break;
case ST_SUBROUTINE:
p = "SUBROUTINE";
break;
@@ -3047,6 +3071,61 @@ check_do_closure (void)
static void parse_progunit (gfc_statement);
+/* Parse a CRITICAL block. */
+
+static void
+parse_critical_block (void)
+{
+ gfc_code *top, *d;
+ gfc_state_data s;
+ gfc_statement st;
+
+ s.ext.end_do_label = new_st.label1;
+
+ accept_statement (ST_CRITICAL);
+ top = gfc_state_stack->tail;
+
+ push_state (&s, COMP_CRITICAL, gfc_new_block);
+
+ d = add_statement ();
+ d->op = EXEC_CRITICAL;
+ top->block = d;
+
+ do
+ {
+ st = parse_executable (ST_NONE);
+
+ switch (st)
+ {
+ case ST_NONE:
+ unexpected_eof ();
+ break;
+
+ case ST_END_CRITICAL:
+ if (s.ext.end_do_label != NULL
+ && s.ext.end_do_label != gfc_statement_label)
+ gfc_error_now ("Statement label in END CRITICAL at %C does not "
+ "match CRITIAL label");
+
+ if (gfc_statement_label != NULL)
+ {
+ new_st.op = EXEC_NOP;
+ add_statement ();
+ }
+ break;
+
+ default:
+ unexpected_statement (st);
+ break;
+ }
+ }
+ while (st != ST_END_CRITICAL);
+
+ pop_state ();
+ accept_statement (st);
+}
+
+
/* Set up the local namespace for a BLOCK construct. */
gfc_namespace*
@@ -3472,9 +3551,12 @@ parse_executable (gfc_statement st)
case ST_CYCLE:
case ST_PAUSE:
case ST_STOP:
+ case ST_ALL_STOP:
case ST_END_SUBROUTINE:
case ST_DO:
+ case ST_CRITICAL:
+ case ST_BLOCK:
case ST_FORALL:
case ST_WHERE:
case ST_SELECT_CASE:
@@ -3522,6 +3604,10 @@ parse_executable (gfc_statement st)
return ST_IMPLIED_ENDDO;
break;
+ case ST_CRITICAL:
+ parse_critical_block ();
+ break;
+
case ST_WHERE_BLOCK:
parse_where_block ();
break;
Index: gcc/fortran/parse.h
===================================================================
--- gcc/fortran/parse.h (revision 156274)
+++ gcc/fortran/parse.h (working copy)
@@ -32,7 +32,7 @@ typedef enum
COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_DERIVED_CONTAINS,
COMP_BLOCK, COMP_IF,
COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM,
- COMP_SELECT_TYPE, COMP_OMP_STRUCTURED_BLOCK
+ COMP_SELECT_TYPE, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL
}
gfc_compile_state;
Index: gcc/fortran/intrinsic.texi
===================================================================
--- gcc/fortran/intrinsic.texi (revision 156274)
+++ gcc/fortran/intrinsic.texi (working copy)
@@ -204,6 +204,7 @@ Some basic guidelines for editing this d
* @code{NINT}: NINT, Nearest whole number
* @code{NOT}: NOT, Logical negation
* @code{NULL}: NULL, Function that returns an disassociated pointer
+* @code{NUM_IMAGES}: NUM_IMAGES, Number of images
* @code{OR}: OR, Bitwise logical OR
* @code{PACK}: PACK, Pack an array into an array of rank one
* @code{PERROR}: PERROR, Print system error message
@@ -8374,6 +8375,49 @@ REAL, POINTER, DIMENSION(:) :: VEC => NU
@end table
+
+@node NUM_IMAGES
+@section @code{NUM_IMAGES} --- Function that returns the number of images
+@fnindex NUM_IMAGES
+@cindex coarray, NUM_IMAGES
+@cindex images, number of
+
+@table @asis
+@item @emph{Description}:
+Returns the number of images.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@code{RESULT = NUM_IMAGES()}
+
+@item @emph{Arguments}: None.
+
+@item @emph{Return value}:
+Scalar default-kind integer.
+
+@item @emph{Example}:
+@smallexample
+INTEGER :: value[*]
+INTEGER :: i
+value = THIS_IMAGE()
+SYNC ALL
+IF (THIS_IMAGE() == 1) THEN
+ DO i = 1, NUM_IMAGES()
+ WRITE(*,'(2(a,i0))') 'value[', i, '] is ', value[i]
+ END DO
+END IF
+@end smallexample
+
+@item @emph{See also}:
+@c FIXME: ref{THIS_IMAGE}
+@end table
+
+
@node OR
@section @code{OR} --- Bitwise logical OR
Index: gcc/fortran/simplify.c
===================================================================
--- gcc/fortran/simplify.c (revision 156274)
+++ gcc/fortran/simplify.c (working copy)
@@ -1928,6 +1928,7 @@ gfc_simplify_exp (gfc_expr *x)
return range_check (result, "EXP");
}
+
gfc_expr *
gfc_simplify_exponent (gfc_expr *x)
{
@@ -3933,6 +3934,17 @@ gfc_simplify_null (gfc_expr *mold)
return result;
}
+
+gfc_expr *
+gfc_simplify_num_images (void)
+{
+ gfc_expr *result;
+ /* FIXME: gfc_current_locus is wrong. */
+ result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus);
+ mpz_set_si (result->value.integer, 1);
+ return result;
+}
+
gfc_expr *
gfc_simplify_or (gfc_expr *x, gfc_expr *y)
Index: libgfortran/runtime/stop.c
===================================================================
--- libgfortran/runtime/stop.c (revision 156274)
+++ libgfortran/runtime/stop.c (working copy)
@@ -53,3 +53,22 @@ stop_string (const char *string, GFC_INT
sys_exit (0);
}
+
+extern void all_stop_string (const char *, GFC_INTEGER_4);
+export_proto(all_stop_string);
+
+
+/* Per Fortran 2008, section 8.4: "Execution of a STOP statement initiates
+ normal termination of execution. Execution of an ALL STOP statement
+ initiates error termination of execution." Thus, all_stop_string returns
+ a nonzero exit status code. */
+void
+all_stop_string (const char *string, GFC_INTEGER_4 len)
+{
+ st_printf ("ALL STOP ");
+ while (len--)
+ st_printf ("%c", *(string++));
+ st_printf ("\n");
+
+ sys_exit (1);
+}
Index: libgfortran/gfortran.map
===================================================================
--- libgfortran/gfortran.map (revision 156274)
+++ libgfortran/gfortran.map (working copy)
@@ -1098,6 +1098,11 @@ GFORTRAN_1.2 {
_gfortran_is_extension_of;
} GFORTRAN_1.1;
+GFORTRAN_1.3 {
+ global:
+ _gfortran_all_stop_string;
+} GFORTRAN_1.2;
+
F2C_1.0 {
global:
_gfortran_f2c_specific__abs_c4;
Index: gcc/testsuite/gfortran.dg/coarray_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/coarray_1.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/coarray_1.f90 (revision 0)
@@ -0,0 +1,18 @@
+! { dg-do compile }
+! { dg-options "-std=f2003" }
+!
+! Coarray support
+! PR fortran/18918
+!
+implicit none
+integer :: n
+critical ! { dg-error "Fortran 2008:" }
+ sync all() ! { dg-error "Fortran 2008:" }
+end critical ! { dg-error "Expecting END PROGRAM" }
+sync memory ! { dg-error "Fortran 2008:" }
+sync images(*) ! { dg-error "Fortran 2008:" }
+
+! num_images is implicitly defined:
+n = num_images() ! { dg-error "convert UNKNOWN to INTEGER" }
+all stop 'stop' ! { dg-error "Fortran 2008:" }
+end
Index: gcc/testsuite/gfortran.dg/coarray_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/coarray_2.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/coarray_2.f90 (revision 0)
@@ -0,0 +1,46 @@
+! { dg-do run }
+! { dg-shouldfail "all stop" }
+!
+! Coarray support
+! PR fortran/18918
+
+implicit none
+integer :: n
+character(len=30) :: str
+critical
+end critical
+myCr: critical
+end critical myCr
+ sync all
+ sync all ( )
+ n = 5
+ sync all (stat=n)
+ if (n /= 0) call abort()
+ n = 5
+ sync all (stat=n,errmsg=str)
+ if (n /= 0) call abort()
+ sync all (errmsg=str)
+
+ sync memory
+ sync memory ( )
+ n = 5
+ sync memory (stat=n)
+ if (n /= 0) call abort()
+ n = 5
+ sync memory (errmsg=str,stat=n)
+ if (n /= 0) call abort()
+ sync memory (errmsg=str)
+
+sync images (*, stat=n)
+sync images (1, errmsg=str)
+sync images ([1],errmsg=str,stat=n)
+
+sync images (*)
+sync images (1)
+sync images ([1])
+
+if (num_images() /= 1) call abort()
+all stop 'stop'
+end
+
+! { dg-output "ALL STOP stop" }
Index: gcc/testsuite/gfortran.dg/coarray_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/coarray_3.f90 (Revision 0)
+++ gcc/testsuite/gfortran.dg/coarray_3.f90 (Revision 0)
@@ -0,0 +1,82 @@
+! { dg-do compile }
+!
+! Coarray support
+! PR fortran/18918
+
+implicit none
+integer :: n, m(1), k
+character(len=30) :: str(2)
+
+critical fkl ! { dg-error "Syntax error in CRITICAL" }
+end critical fkl ! { dg-error "Expecting END PROGRAM" }
+
+sync all (stat=1) ! { dg-error "Syntax error in SYNC ALL" }
+sync all ( stat = n,stat=k) ! { dg-error "Redundant STAT" }
+sync memory (errmsg=str)
+sync memory (errmsg=n) ! { dg-error "must be a scalar CHARACTER variable" }
+sync images (*, stat=1.0) ! { dg-error "Syntax error in SYNC IMAGES" }
+sync images (-1) ! { dg-error "must between 1 and num_images" }
+sync images (1)
+sync images ( [ 1 ])
+sync images ( m(1:0) )
+sync images ( reshape([1],[1,1])) ! { dg-error "must be a scalar or rank-1" }
+end
+
+subroutine foo
+critical
+ stop 'error' ! { dg-error "Image control statement STOP" }
+ sync all ! { dg-error "Image control statement SYNC" }
+ return 1 ! { dg-error "Image control statement RETURN" }
+ critical ! { dg-error "Nested CRITICAL block" }
+ end critical
+end critical ! { dg-error "Expecting END SUBROUTINE" }
+end
+
+subroutine bar()
+do
+ critical
+ cycle ! { dg-error "leaves CRITICAL block" }
+ end critical
+end do
+
+outer: do
+ critical
+ do
+ exit
+ exit outer ! { dg-error "leaves CRITICAL block" }
+ end do
+ end critical
+end do outer
+end subroutine bar
+
+
+subroutine sub()
+333 continue ! { dg-error "leaves CRITCAL block" }
+do
+ critical
+ if (.false.) then
+ goto 333 ! { dg-error "leaves CRITCAL block" }
+ goto 777
+777 end if
+ end critical
+end do
+
+if (.true.) then
+outer: do
+ critical
+ do
+ goto 444
+ goto 555 ! { dg-error "leaves CRITCAL block" }
+ end do
+444 continue
+ end critical
+ end do outer
+555 end if ! { dg-error "leaves CRITCAL block" }
+end subroutine sub
+
+pure subroutine pureSub()
+ critical ! { dg-error "Image control statement CRITICAL" }
+ end critical ! { dg-error "Expecting END SUBROUTINE statement" }
+ sync all ! { dg-error "Image control statement SYNC" }
+ all stop ! { dg-error "not allowed in PURE procedure" }
+end subroutine pureSub