re PR fortran/39997 (Procedure(), pointer & implicit typing: rejects-valid / accepts-invalid?)

2010-04-06  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, ERROR 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 ERROR 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, ERROR STOP,
        and SYNC statements.
        * trans.h (gfor_fndecl_error_stop_string) Add variable.
        * resolve.c (resolve_sync): Add function.
        (gfc_resolve_blocks): Handle CRITICAL.
        (resolve_code): Handle CRITICAL, ERROR STOP,
        (resolve_branch): Add CRITICAL constraint check.
        and SYNC statements.
        * st.c (gfc_free_statement): Add new statements.
        * trans-decl.c (gfor_fndecl_error_stop_string): Global variable.
        (gfc_build_builtin_function_decls): Initialize it.
        * match.c (gfc_match_if): Handle ERROR STOP and SYNC.
        (gfc_match_critical, gfc_match_error_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 ERROR STOP.
        * match.h (gfc_match_critical, gfc_match_error_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-04-06  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-04-06  Tobias Burnus  <burnus@net-b.de>

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

From-SVN: r158008

26 files changed, 922 insertions, 35 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 97a2fca..8af3668 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,47 @@
 2010-04-06  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, ERROR 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 ERROR 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, ERROR STOP,
+	and SYNC statements.
+	* trans.h (gfor_fndecl_error_stop_string) Add variable.
+	* resolve.c (resolve_sync): Add function.
+	(gfc_resolve_blocks): Handle CRITICAL.
+	(resolve_code): Handle CRITICAL, ERROR STOP,
+	(resolve_branch): Add CRITICAL constraint check.
+	and SYNC statements.
+	* st.c (gfc_free_statement): Add new statements.
+	* trans-decl.c (gfor_fndecl_error_stop_string): Global variable.
+	(gfc_build_builtin_function_decls): Initialize it.
+	* match.c (gfc_match_if): Handle ERROR STOP and SYNC.
+	(gfc_match_critical, gfc_match_error_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 ERROR STOP.
+	* match.h (gfc_match_critical, gfc_match_error_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-04-06  Tobias Burnus  <burnus@net-b.de>
+
 	PR fortran/43178
 	* trans-array.c (gfc_conv_expr_descriptor): Update
 	gfc_trans_scalar_assign call.
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 692078a..9237503 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -5476,6 +5476,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;
@@ -5534,7 +5540,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..6c67e7d 100644
--- a/gcc/fortran/dump-parse-tree.c
+++ b/gcc/fortran/dump-parse-tree.c
@@ -1,5 +1,5 @@
 /* Parse tree dumper
-   Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009
+   Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
    Free Software Foundation, Inc.
    Contributed by Steven Bosscher
 
@@ -1273,6 +1273,10 @@ show_code_node (int level, gfc_code *c)
 
       break;
 
+    case EXEC_ERROR_STOP:
+      fputs ("ERROR ", 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 af1f1c6..1f98824 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -214,9 +214,9 @@ typedef enum
   ST_END_FILE, ST_FINAL, ST_FLUSH, ST_END_FORALL, ST_END_FUNCTION, ST_ENDIF,
   ST_END_INTERFACE, ST_END_MODULE, ST_END_PROGRAM, ST_END_SELECT,
   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_ERROR_STOP, 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_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, 
@@ -231,7 +231,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;
@@ -462,6 +462,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,
@@ -1976,12 +1977,13 @@ gfc_forall_iterator;
 typedef enum
 {
   EXEC_NOP = 1, EXEC_END_BLOCK, EXEC_ASSIGN, EXEC_LABEL_ASSIGN,
-  EXEC_POINTER_ASSIGN,
+  EXEC_POINTER_ASSIGN, EXEC_CRITICAL, EXEC_ERROR_STOP,
   EXEC_GOTO, EXEC_CALL, EXEC_COMPCALL, EXEC_ASSIGN_CALL, EXEC_RETURN,
   EXEC_ENTRY, EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, EXEC_INIT_ASSIGN,
   EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT, EXEC_BLOCK,
   EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT, EXEC_CALL_PPC,
   EXEC_ALLOCATE, EXEC_DEALLOCATE, EXEC_END_PROCEDURE, EXEC_SELECT_TYPE,
+  EXEC_SYNC_ALL, EXEC_SYNC_MEMORY, EXEC_SYNC_IMAGES,
   EXEC_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 684b2cf..fbfc47a 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -2221,6 +2221,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..b675de2 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -1,7 +1,7 @@
 /* Header file for intrinsics check, resolve and simplify function
    prototypes.
-   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
-   Free Software Foundation, Inc.
+   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+   2010 Free Software Foundation, Inc.
    Contributed by Andy Vaught & Katherine Holcomb
 
 This file is part of GCC.
@@ -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 b9b1c25..52992ba 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..48bb733 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1,6 +1,6 @@
 /* Matching subroutines in all sizes, shapes and colors.
-   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
-   Free Software Foundation, Inc.
+   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+   2010 Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
 This file is part of GCC.
@@ -1547,6 +1547,7 @@ gfc_match_if (gfc_statement *if_type)
   match ("cycle", gfc_match_cycle, ST_CYCLE)
   match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
   match ("end file", gfc_match_endfile, ST_END_FILE)
+  match ("error stop", gfc_match_error_stop, ST_ERROR_STOP)
   match ("exit", gfc_match_exit, ST_EXIT)
   match ("flush", gfc_match_flush, ST_FLUSH)
   match ("forall", match_simple_forall, ST_FORALL)
@@ -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_ERROR_STOP:
+      new_st.op = EXEC_ERROR_STOP;
+      break;
+    case ST_PAUSE:
+      new_st.op = EXEC_PAUSE;
+      break;
+    default:
+      gcc_unreachable ();
+    }
+
   new_st.expr1 = e;
   new_st.ext.stop_code = stop_code;
 
@@ -2022,6 +2099,193 @@ gfc_match_stop (void)
 }
 
 
+/* Match the ERROR STOP statement.  */
+
+match
+gfc_match_error_stop (void)
+{
+  if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: ERROR STOP statement at %C")
+      == FAILURE)
+    return MATCH_ERROR;
+
+  return gfc_match_stopcode (ST_ERROR_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 2025005..b03ee54 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_error_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 2679e92..7d935c3 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);
 
@@ -362,6 +363,7 @@ decode_statement (void)
       match ("else", gfc_match_else, ST_ELSE);
       match ("else where", gfc_match_elsewhere, ST_ELSEWHERE);
       match ("else if", gfc_match_elseif, ST_ELSEIF);
+      match ("error stop", gfc_match_error_stop, ST_ERROR_STOP);
       match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
 
       if (gfc_match_end (&st) == MATCH_YES)
@@ -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_ERROR_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;
@@ -1176,6 +1183,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 +1219,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;
@@ -1251,6 +1264,9 @@ gfc_ascii_statement (gfc_statement st)
     case ST_EQUIVALENCE:
       p = "EQUIVALENCE";
       break;
+    case ST_ERROR_STOP:
+      p = "ERROR STOP";
+      break;
     case ST_EXIT:
       p = "EXIT";
       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_ERROR_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..649e54d 100644
--- a/gcc/fortran/parse.h
+++ b/gcc/fortran/parse.h
@@ -1,5 +1,5 @@
 /* Parser header
-   Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008
+   Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
    Free Software Foundation, Inc.
    Contributed by Steven Bosscher
 
@@ -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 24ec7a8..8ef347d 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -7315,6 +7315,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.  */
 
@@ -7355,15 +7397,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)
     {
@@ -7788,6 +7851,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:
@@ -8068,10 +8132,18 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	case EXEC_CYCLE:
 	case EXEC_PAUSE:
 	case EXEC_STOP:
+	case EXEC_ERROR_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..50cd6da 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -1,6 +1,6 @@
 /* Simplify intrinsic functions at compile-time.
-   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
-   Free Software Foundation, Inc.
+   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+   2010 Free Software Foundation, Inc.
    Contributed by Andy Vaught & Katherine Holcomb
 
 This file is part of GCC.
@@ -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..ffef22d 100644
--- a/gcc/fortran/st.c
+++ b/gcc/fortran/st.c
@@ -1,5 +1,5 @@
 /* Build executable statement trees.
-   Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009
+   Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
    Free Software Foundation, Inc.
    Contributed by Andy Vaught
 
@@ -98,6 +98,7 @@ gfc_free_statement (gfc_code *p)
     case EXEC_IF:
     case EXEC_PAUSE:
     case EXEC_STOP:
+    case EXEC_ERROR_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 b207864..53c4b47 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_error_stop_string;
 tree gfor_fndecl_runtime_error;
 tree gfor_fndecl_runtime_error_at;
 tree gfor_fndecl_runtime_warning_at;
@@ -2725,6 +2726,13 @@ gfc_build_builtin_function_decls (void)
   /* Stop doesn't return.  */
   TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
 
+  gfor_fndecl_error_stop_string =
+    gfc_build_library_function_decl (get_identifier (PREFIX("error_stop_string")),
+				     void_type_node, 2, pchar_type_node,
+                                     gfc_int4_type_node);
+  /* ERROR STOP doesn't return.  */
+  TREE_THIS_VOLATILE (gfor_fndecl_error_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 7ebb1e9..0b215f2 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 error_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);
+			     error_stop ? gfor_fndecl_error_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 56221f5..b349545 100644
--- a/gcc/fortran/trans-stmt.h
+++ b/gcc/fortran/trans-stmt.h
@@ -36,13 +36,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 *);
@@ -51,6 +52,7 @@ tree gfc_trans_block_construct (gfc_code *);
 tree gfc_trans_do (gfc_code *, tree);
 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 17241ac..c1993f9 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1105,6 +1105,10 @@ trans_code (gfc_code * code, tree cond)
 	  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 @@ trans_code (gfc_code * code, tree cond)
 	  break;
 
 	case EXEC_STOP:
-	  res = gfc_trans_stop (code);
+	case EXEC_ERROR_STOP:
+	  res = gfc_trans_stop (code, code->op == EXEC_ERROR_STOP);
 	  break;
 
 	case EXEC_CALL:
@@ -1191,6 +1196,12 @@ trans_code (gfc_code * code, tree cond)
 	  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 3376931..fe34f69 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -534,6 +534,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_error_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/ChangeLog b/gcc/testsuite/ChangeLog
index 66018c5..a65ba45 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2010-04-06  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-04-06  Jason Merrill  <jason@redhat.com>
 
 	PR c++/43648
diff --git a/gcc/testsuite/gfortran.dg/coarray_1.f90 b/gcc/testsuite/gfortran.dg/coarray_1.f90
new file mode 100644
index 0000000..ba10d64
--- /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" }
+error 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..1fcb9b8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_2.f90
@@ -0,0 +1,46 @@
+! { dg-do run }
+! { dg-shouldfail "error 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()
+error stop 'stop'
+end
+
+! { dg-output "ERROR 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..648f2fa
--- /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" }
+  error 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/ChangeLog b/libgfortran/ChangeLog
index 70700a3..78c6b04 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,9 @@
+2010-04-06  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/39997
+	* runtime/stop.c (error_stop_string): New function.
+	* gfortran.map (_gfortran_error_stop_string): Add.
+
 2010-04-02  Ralf Wildenhues  <Ralf.Wildenhues@gmx.de>
 
 	* Makefile.in: Regenerate.
@@ -7,7 +13,7 @@
 
 	PR libfortran/43605
 	* io/intrinsics.c (gf_ftell): New function, seek to correct offset.
-        (ftell): Call gf_ftell.
+	(ftell): Call gf_ftell.
 	(FTELL_SUB): Likewise.
 
 2010-04-01  Paul Thomas  <pault@gcc.gnu.org>
diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map
index 3541d14..bcca957 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_error_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..14a88c4 100644
--- a/libgfortran/runtime/stop.c
+++ b/libgfortran/runtime/stop.c
@@ -1,5 +1,5 @@
 /* Implementation of the STOP statement.
-   Copyright 2002, 2005, 2007, 2009 Free Software Foundation, Inc.
+   Copyright 2002, 2005, 2007, 2009, 2010 Free Software Foundation, Inc.
    Contributed by Paul Brook <paul@nowt.org>
 
 This file is part of the GNU Fortran 95 runtime library (libgfortran).
@@ -53,3 +53,22 @@ stop_string (const char *string, GFC_INTEGER_4 len)
 
   sys_exit (0);
 }
+
+extern void error_stop_string (const char *, GFC_INTEGER_4);
+export_proto(error_stop_string);
+
+
+/* Per Fortran 2008, section 8.4:  "Execution of a STOP statement initiates
+   normal termination of execution. Execution of an ERROR STOP statement
+   initiates error termination of execution."  Thus, error_stop_string returns
+   a nonzero exit status code.  */
+void
+error_stop_string (const char *string, GFC_INTEGER_4 len)
+{
+  st_printf ("ERROR STOP ");
+  while (len--)
+    st_printf ("%c", *(string++));
+  st_printf ("\n");
+
+  sys_exit (1);
+}