This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

Re: [Patch, Fortran, 4.6] F2008 - first coarray patch


On 04.02.2010 17:05, Daniel Kraft wrote:
> Tobias Burnus wrote:
>> OK for the 4.6 trunk?
>
> Yes, but please consider my comments below.

I have updated the patch - see below. I have also attached an interdiff.

> +      if (c->expr3 != NULL)
> +        {
> +    }
>
> (and following)  I'm not sure what happened here, but it looks as if
> the indentation is screwed up (for matching {} pairs).

Space instead of a tab before {.

>    if (bitmap_bit_p (cs_base->reachable_labels, label->value))
> [...]
>
> I'm sure this is correct, but please enlighten me what
> reachable_labels does exactly store.  Is it here that a label inside
> the CRITICAL block is not reachable from the next outer block (ie. not
> allowed to jump inside a block) and thus branching to a label that
> *is* reachable from the parent must jump outside the block?  (Or
> something similar?)

Yes, that's the logic. Thanks for the review!

Tobias

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index a2ce498..9dd0690 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -5536,7 +5536,8 @@ gfc_match_end (gfc_statement *st)
     {
 
       if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
-	  && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK)
+	  && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK
+	  && *st != ST_END_CRITICAL)
 	return MATCH_YES;
 
       if (!block_name)
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index 1956466..234045f 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -1290,12 +1290,12 @@ show_code_node (int level, gfc_code *c)
     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);
 	}
@@ -1304,12 +1304,12 @@ show_code_node (int level, gfc_code *c)
     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);
 	}
@@ -1322,12 +1322,12 @@ show_code_node (int level, gfc_code *c)
       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);
 	}
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index f70380a..149a169 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1922,9 +1922,9 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op)
       break;
     else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
       o = p;
-    else if (p-> state == COMP_CRITICAL)
+    else if (p->state == COMP_CRITICAL)
       {
- 	gfc_error("%s statement at %C leaves CRITICAL block",
+ 	gfc_error("%s statement at %C leaves CRITICAL construct",
 		  gfc_ascii_statement (st));
 	return MATCH_ERROR;
       }
@@ -2041,10 +2041,21 @@ gfc_match_stopcode (gfc_statement st)
       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;
+  switch (st)
+    {
+    case ST_STOP:
+      new_st.op = EXEC_STOP;
+      break;
+    case ST_ALL_STOP:
+      new_st.op = EXEC_ALL_STOP;
+      break;
+    case ST_PAUSE:
+      new_st.op = EXEC_PAUSE;
+      break;
+    default:
+      gcc_unreachable ();
+    }
+      
   new_st.expr1 = e;
   new_st.ext.stop_code = stop_code;
 
@@ -2146,7 +2157,7 @@ sync_statement (gfc_statement st)
   if (st == ST_SYNC_IMAGES)
     {
       /* Denote '*' as imageset == NULL.  */
-      m =gfc_match_char ('*');
+      m = gfc_match_char ('*');
       if (m == MATCH_ERROR)
 	goto syntax;
       if (m == MATCH_NO)
@@ -2214,12 +2225,21 @@ sync_statement (gfc_statement st)
     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;
+  switch (st)
+    {
+    case ST_SYNC_ALL:
+      new_st.op = EXEC_SYNC_ALL;
+      break;
+    case ST_SYNC_IMAGES:
+      new_st.op = EXEC_SYNC_IMAGES;
+      break;
+    case ST_SYNC_MEMORY:
+      new_st.op = EXEC_SYNC_MEMORY;
+      break;
+    default:
+      gcc_unreachable ();
+    }
+
   new_st.expr1 = imageset;
   new_st.expr2 = stat;
   new_st.expr3 = errmsg;
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 41f2752..5ce635e 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -1088,6 +1088,7 @@ check_statement_label (gfc_statement st)
     case ST_ENDDO:
     case ST_ENDIF:
     case ST_END_SELECT:
+    case ST_END_CRITICAL:
     case_executable:
     case_exec_markers:
       type = ST_LABEL_TARGET;
@@ -1579,6 +1580,7 @@ accept_statement (gfc_statement st)
 
     case ST_ENDIF:
     case ST_END_SELECT:
+    case ST_END_CRITICAL:
       if (gfc_statement_label != NULL)
 	{
 	  new_st.op = EXEC_END_BLOCK;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 528aef4..c4c6844 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -7376,11 +7376,14 @@ resolve_branch (gfc_st_label *label, gfc_code *code)
 
   if (bitmap_bit_p (cs_base->reachable_labels, label->value))
     {
+      /* Check now whether there is a CRITICAL construct; if so, check
+	 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->prev->reachable_labels, label->value))
-	  gfc_error ("GOTO statement at %L leaves CRITCAL block for label at "
-		     "%L", &code->loc, &label->where);
+	    && 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);
 
       return;
     }
@@ -7390,18 +7393,22 @@ resolve_branch (gfc_st_label *label, gfc_code *code)
     case we find it by going up the code_stack.  */
 
   for (stack = cs_base; stack; stack = stack->prev)
-    if (stack->current->next && stack->current->next->here == label)
-      break;
+    {
+      if (stack->current->next && stack->current->next->here == label)
+	break;
+      if (stack->current->op == EXEC_CRITICAL)
+	{
+	  /* Note: A label at END CRITICAL does not leave the CRITICAL
+	     construct as END CRITICAL is still part of it.  */
+	  gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
+		      " at %L", &code->loc, &label->where);
+	  return;
+	}
+    }
 
   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;
     }
 
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index fd913d2..8db120a 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -614,7 +614,7 @@ 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)
+  if ((code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) || code->expr2)
     {
       gfc_init_se (&se, NULL);
       gfc_start_block (&se.pre);
@@ -622,7 +622,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type __attribute__ ((unused)))
 
   /* 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
+  if (code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
       && code->expr1->rank == 0)
     {
       tree cond;
@@ -643,7 +643,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type __attribute__ ((unused)))
       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)
+  if ((code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) || code->expr2)
     return gfc_finish_block (&se.pre);
  
   return NULL_TREE;
diff --git a/gcc/testsuite/gfortran.dg/coarray_3.f90 b/gcc/testsuite/gfortran.dg/coarray_3.f90
index 9bfdf50..8056126 100644
--- a/gcc/testsuite/gfortran.dg/coarray_3.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_3.f90
@@ -35,7 +35,7 @@ end
 subroutine bar()
 do
   critical
-    cycle ! { dg-error "leaves CRITICAL block" }
+    cycle ! { dg-error "leaves CRITICAL construct" }
   end critical
 end do
 
@@ -43,7 +43,7 @@ outer: do
   critical
     do
       exit
-      exit outer ! { dg-error "leaves CRITICAL block" }
+      exit outer ! { dg-error "leaves CRITICAL construct" }
     end do
   end critical
 end do outer
@@ -51,12 +51,12 @@ end subroutine bar
 
 
 subroutine sub()
-333 continue ! { dg-error "leaves CRITCAL block" }
+333 continue ! { dg-error "leaves CRITICAL construct" }
 do
   critical
-  if (.false.) then
-    goto 333 ! { dg-error "leaves CRITCAL block" }
-    goto 777
+    if (.false.) then
+      goto 333 ! { dg-error "leaves CRITICAL construct" }
+      goto 777
 777 end if
   end critical
 end do
@@ -66,12 +66,12 @@ outer: do
   critical
     do
       goto 444
-      goto 555 ! { dg-error "leaves CRITCAL block" }
+      goto 555 ! { dg-error "leaves CRITICAL construct" }
     end do
 444 continue
   end critical
  end do outer
-555 end if ! { dg-error "leaves CRITCAL block" }
+555 end if ! { dg-error "leaves CRITICAL construct" }
 end subroutine sub
 
 pure subroutine pureSub()
@@ -80,3 +80,20 @@ pure subroutine pureSub()
   sync all ! { dg-error "Image control statement SYNC" }
   all stop ! { dg-error "not allowed in PURE procedure" }
 end subroutine pureSub
+
+
+SUBROUTINE TEST
+   goto 10 ! { dg-warning "is not in the same block" }
+   CRITICAL
+     goto 5  ! OK
+5    continue ! { dg-warning "is not in the same block" }
+     goto 10 ! OK
+     goto 20 ! { dg-error "leaves CRITICAL construct" }
+     goto 30 ! { dg-error "leaves CRITICAL construct" }
+10 END CRITICAL ! { dg-warning "is not in the same block" }
+   goto 5 ! { dg-warning "is not in the same block" }
+20 continue ! { dg-error "leaves CRITICAL construct" }
+   BLOCK
+30   continue ! { dg-error "leaves CRITICAL construct" }
+   END BLOCK
+end SUBROUTINE TEST
 gcc/fortran/decl.c                      |    9 -
 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                     |  275 +++++++++++++++++++++++++++++++-
 gcc/fortran/match.h                     |    5
 gcc/fortran/parse.c                     |  100 ++++++++++-
 gcc/fortran/parse.h                     |    2
 gcc/fortran/resolve.c                   |   78 ++++++++-
 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 |   99 +++++++++++
 libgfortran/gfortran.map                |    5
 libgfortran/runtime/stop.c              |   19 ++
 23 files changed, 855 insertions(+), 23 deletions(-)

2010-02-07  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-02-07  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-02-07  Tobias Burnus  <burnus@net-b.de>

	PR fortran/39997
	* runtime/stop.c (all_stop_string): New function.
	* gfortran.map (_gfortran_all_stop_string): Add.

diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 015d6a4..9dd0690 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -5472,6 +5472,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;
@@ -5530,7 +5536,8 @@ gfc_match_end (gfc_statement *st)
     {
 
       if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
-	  && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK)
+	  && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK
+	  && *st != ST_END_CRITICAL)
 	return MATCH_YES;
 
       if (!block_name)
diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c
index f363816..234045f 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -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);
 
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 5b8f9c1..3d78e8e 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -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,
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 859fd4b..09920ca 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -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,
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index cf436db..2586702 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -297,6 +297,7 @@ gfc_expr *gfc_simplify_nearest (gfc_expr *, 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 *);
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index d37c807..a91ad4c 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -204,6 +204,7 @@ Some basic guidelines for editing this document:
 * @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
@@ -8375,6 +8376,49 @@ REAL, POINTER, DIMENSION(:) :: VEC => NULL ()
 
 
 
+@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
 @fnindex OR
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index c67427c..149a169 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -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, int flag)
 }
 
 
+/* 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_exec_op op)
       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 construct",
+		  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,27 @@ 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;
+    }
+
+  switch (st)
+    {
+    case ST_STOP:
+      new_st.op = EXEC_STOP;
+      break;
+    case ST_ALL_STOP:
+      new_st.op = EXEC_ALL_STOP;
+      break;
+    case ST_PAUSE:
+      new_st.op = EXEC_PAUSE;
+      break;
+    default:
+      gcc_unreachable ();
+    }
+      
   new_st.expr1 = e;
   new_st.ext.stop_code = stop_code;
 
@@ -2022,6 +2099,193 @@ 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:
+  switch (st)
+    {
+    case ST_SYNC_ALL:
+      new_st.op = EXEC_SYNC_ALL;
+      break;
+    case ST_SYNC_IMAGES:
+      new_st.op = EXEC_SYNC_IMAGES;
+      break;
+    case ST_SYNC_MEMORY:
+      new_st.op = EXEC_SYNC_MEMORY;
+      break;
+    default:
+      gcc_unreachable ();
+    }
+
+  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 +3114,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;
 
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 3c0f1c0..f26e6ca 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -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);
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 9e8a123..5ce635e 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -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 */
 
@@ -1082,6 +1088,7 @@ check_statement_label (gfc_statement st)
     case ST_ENDDO:
     case ST_ENDIF:
     case ST_END_SELECT:
+    case ST_END_CRITICAL:
     case_executable:
     case_exec_markers:
       type = ST_LABEL_TARGET;
@@ -1146,6 +1153,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 +1186,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 +1222,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 +1355,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;
@@ -1555,6 +1580,7 @@ accept_statement (gfc_statement st)
 
     case ST_ENDIF:
     case ST_END_SELECT:
+    case ST_END_CRITICAL:
       if (gfc_statement_label != NULL)
 	{
 	  new_st.op = EXEC_END_BLOCK;
@@ -3047,6 +3073,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 +3553,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 +3606,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;
diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h
index e0a2969..5da9939 100644
--- a/gcc/fortran/parse.h
+++ b/gcc/fortran/parse.h
@@ -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;
 
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index d0aa6ad..c4c6844 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -7293,6 +7293,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.  */
 
@@ -7333,15 +7375,36 @@ resolve_branch (gfc_st_label *label, gfc_code *code)
      the bitmap reachable_labels.  */
 
   if (bitmap_bit_p (cs_base->reachable_labels, label->value))
-    return;
+    {
+      /* Check now whether there is a CRITICAL construct; if so, check
+	 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);
+
+      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
     case we find it by going up the code_stack.  */
 
   for (stack = cs_base; stack; stack = stack->prev)
-    if (stack->current->next && stack->current->next->here == label)
-      break;
+    {
+      if (stack->current->next && stack->current->next->here == label)
+	break;
+      if (stack->current->op == EXEC_CRITICAL)
+	{
+	  /* Note: A label at END CRITICAL does not leave the CRITICAL
+	     construct as END CRITICAL is still part of it.  */
+	  gfc_error ("GOTO statement at %L leaves CRITICAL construct for label"
+		      " at %L", &code->loc, &label->where);
+	  return;
+	}
+    }
 
   if (stack)
     {
@@ -7766,6 +7829,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns)
 	case EXEC_FORALL:
 	case EXEC_DO:
 	case EXEC_DO_WHILE:
+	case EXEC_CRITICAL:
 	case EXEC_READ:
 	case EXEC_WRITE:
 	case EXEC_IOLENGTH:
@@ -8040,10 +8104,18 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	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:
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 8768cb6..9d14ef1 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -1928,6 +1928,7 @@ gfc_simplify_exp (gfc_expr *x)
   return range_check (result, "EXP");
 }
 
+
 gfc_expr *
 gfc_simplify_exponent (gfc_expr *x)
 {
@@ -3935,6 +3936,17 @@ gfc_simplify_null (gfc_expr *mold)
 
 
 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)
 {
   gfc_expr *result;
diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c
index f1765e6..5f8090d 100644
--- a/gcc/fortran/st.c
+++ b/gcc/fortran/st.c
@@ -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:
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 062310a..f9a228e 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -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);
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 84c3c85..8db120a 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -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.  */
 
diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h
index e6faacd..f9a619c 100644
--- a/gcc/fortran/trans-stmt.h
+++ b/gcc/fortran/trans-stmt.h
@@ -33,13 +33,14 @@ tree gfc_trans_class_assign (gfc_code *code);
 
 /* 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 *);
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index a5bb641..9f4b8ed 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1108,6 +1108,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;
@@ -1129,7 +1133,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:
@@ -1194,6 +1199,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;
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 30a7753..6ceb962 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -533,6 +533,7 @@ extern GTY(()) tree gfor_fndecl_pause_numeric;
 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;
diff --git a/gcc/testsuite/gfortran.dg/coarray_1.f90 b/gcc/testsuite/gfortran.dg/coarray_1.f90
new file mode 100644
index 0000000..da05884
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_1.f90
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/coarray_2.f90 b/gcc/testsuite/gfortran.dg/coarray_2.f90
new file mode 100644
index 0000000..2d11ca3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_2.f90
@@ -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" }
diff --git a/gcc/testsuite/gfortran.dg/coarray_3.f90 b/gcc/testsuite/gfortran.dg/coarray_3.f90
new file mode 100644
index 0000000..8056126
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_3.f90
@@ -0,0 +1,99 @@
+! { 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 construct" }
+  end critical
+end do
+
+outer: do
+  critical
+    do
+      exit
+      exit outer ! { dg-error "leaves CRITICAL construct" }
+    end do
+  end critical
+end do outer
+end subroutine bar
+
+
+subroutine sub()
+333 continue ! { dg-error "leaves CRITICAL construct" }
+do
+  critical
+    if (.false.) then
+      goto 333 ! { dg-error "leaves CRITICAL construct" }
+      goto 777
+777 end if
+  end critical
+end do
+
+if (.true.) then
+outer: do
+  critical
+    do
+      goto 444
+      goto 555 ! { dg-error "leaves CRITICAL construct" }
+    end do
+444 continue
+  end critical
+ end do outer
+555 end if ! { dg-error "leaves CRITICAL construct" }
+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
+
+
+SUBROUTINE TEST
+   goto 10 ! { dg-warning "is not in the same block" }
+   CRITICAL
+     goto 5  ! OK
+5    continue ! { dg-warning "is not in the same block" }
+     goto 10 ! OK
+     goto 20 ! { dg-error "leaves CRITICAL construct" }
+     goto 30 ! { dg-error "leaves CRITICAL construct" }
+10 END CRITICAL ! { dg-warning "is not in the same block" }
+   goto 5 ! { dg-warning "is not in the same block" }
+20 continue ! { dg-error "leaves CRITICAL construct" }
+   BLOCK
+30   continue ! { dg-error "leaves CRITICAL construct" }
+   END BLOCK
+end SUBROUTINE TEST
diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map
index 3541d14..200bed6 100644
--- a/libgfortran/gfortran.map
+++ b/libgfortran/gfortran.map
@@ -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;
diff --git a/libgfortran/runtime/stop.c b/libgfortran/runtime/stop.c
index 8c4247d..d434d87 100644
--- a/libgfortran/runtime/stop.c
+++ b/libgfortran/runtime/stop.c
@@ -53,3 +53,22 @@ stop_string (const char *string, GFC_INTEGER_4 len)
 
   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 Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]