check.c (gfc_check_atomic): Update for STAT=.

gcc/fortran/
2014-07-12  Tobias Burnus  <burnus@net-b.de>

        * check.c (gfc_check_atomic): Update for STAT=.
        (gfc_check_atomic_def, gfc_check_atomic_ref): Update call.
        (gfc_check_atomic_op, gfc_check_atomic_cas,
        gfc_check_atomic_fetch_op): New.
        * gfortran.h (gfc_isym_id): GFC_ISYM_ATOMIC_CAS,
        * GFC_ISYM_ATOMIC_ADD,
        GFC_ISYM_ATOMIC_AND, GFC_ISYM_ATOMIC_OR, GFC_ISYM_ATOMIC_XOR,
        GFC_ISYM_ATOMIC_FETCH_ADD, GFC_ISYM_ATOMIC_FETCH_AND,
        GFC_ISYM_ATOMIC_FETCH_OR and GFC_ISYM_ATOMIC_FETCH_XOR.
        * intrinsic.c (add_subroutines): Handle them.
        * intrinsic.texi: Add documentation for them.
        (ATOMIC_REF, ATOMIC_DEFINE): Add STAT=.
        (ISO_FORTRAN_ENV): Add STAT_FAILED_IMAGE.
        * intrinsic.h (gfc_check_atomic_op, gfc_check_atomic_cas,
        gfc_check_atomic_fetch_op): New
        prototypes.
        * libgfortran.h (libgfortran_stat_codes): Add
        * GFC_STAT_FAILED_IMAGE.
        * iso-fortran-env.def: Add it.
        * trans-intrinsic.c (conv_intrinsic_atomic_op): Renamed from
        conv_intrinsic_atomic_ref; handle more atomics.
        (conv_intrinsic_atomic_def): Handle STAT=.
        (conv_intrinsic_atomic_cas): New.
        (gfc_conv_intrinsic_subroutine): Handle new atomics.

gcc/testsuite/
2014-07-12  Tobias Burnus  <burnus@net-b.de>

        * gfortran.dg/coarray_atomic_1.f90: Update dg-error.
        * gfortran.dg/coarray_atomic_2.f90: New.
        * gfortran.dg/coarray_atomic_3.f90: New.
        * gfortran.dg/coarray_atomic_4.f90: New.
        * gfortran.dg/coarray/atomic_2.f90: New.

From-SVN: r212483

gcc/fortran/ChangeLog

+2014-07-12  Tobias Burnus  <burnus@net-b.de>
+
+	* check.c (gfc_check_atomic): Update for STAT=.
+	(gfc_check_atomic_def, gfc_check_atomic_ref): Update call.
+	(gfc_check_atomic_op, gfc_check_atomic_cas,
+	gfc_check_atomic_fetch_op): New.
+	* gfortran.h (gfc_isym_id): GFC_ISYM_ATOMIC_CAS, GFC_ISYM_ATOMIC_ADD,
+	GFC_ISYM_ATOMIC_AND, GFC_ISYM_ATOMIC_OR, GFC_ISYM_ATOMIC_XOR,
+	GFC_ISYM_ATOMIC_FETCH_ADD, GFC_ISYM_ATOMIC_FETCH_AND,
+	GFC_ISYM_ATOMIC_FETCH_OR and GFC_ISYM_ATOMIC_FETCH_XOR.
+	* intrinsic.c (add_subroutines): Handle them.
+	* intrinsic.texi: Add documentation for them.
+	(ATOMIC_REF, ATOMIC_DEFINE): Add STAT=.
+	(ISO_FORTRAN_ENV): Add STAT_FAILED_IMAGE.
+	* intrinsic.h (gfc_check_atomic_op, gfc_check_atomic_cas,
+	gfc_check_atomic_fetch_op): New
+	prototypes.
+	* libgfortran.h (libgfortran_stat_codes): Add GFC_STAT_FAILED_IMAGE.
+	* iso-fortran-env.def: Add it.
+	* trans-intrinsic.c (conv_intrinsic_atomic_op): Renamed from
+	conv_intrinsic_atomic_ref; handle more atomics.
+	(conv_intrinsic_atomic_def): Handle STAT=.
+	(conv_intrinsic_atomic_cas): New.
+	(gfc_conv_intrinsic_subroutine): Handle new atomics.
+
 2014-07-09  Bernd Schmidt  <bernds@codesourcery.com>
 
 	* trans-array.c (gfc_build_constant_array_constructor): Build a

gcc/fortran/check.c

@@ -1006,12 +1006,11 @@ gfc_check_atan2 (gfc_expr *y, gfc_expr *x)
 
 
 static bool
-gfc_check_atomic (gfc_expr *atom, gfc_expr *value)
+gfc_check_atomic (gfc_expr *atom, int atom_no, gfc_expr *value, int val_no,
+		  gfc_expr *stat, int stat_no)
 {
-  if (atom->expr_type == EXPR_FUNCTION
-      && atom->value.function.isym
-      && atom->value.function.isym->id == GFC_ISYM_CAF_GET)
-    atom = atom->value.function.actual->expr;
+  if (!scalar_check (atom, atom_no) || !scalar_check (value, val_no))
+    return false;
 
   if (!(atom->ts.type == BT_INTEGER && atom->ts.kind == gfc_atomic_int_kind)
       && !(atom->ts.type == BT_LOGICAL
@@ -1032,27 +1031,41 @@ gfc_check_atomic (gfc_expr *atom, gfc_expr *value)
 
   if (atom->ts.type != value->ts.type)
     {
-      gfc_error ("ATOM and VALUE argument of the %s intrinsic function shall "
-		 "have the same type at %L", gfc_current_intrinsic,
-		 &value->where);
+      gfc_error ("'%s' argument of '%s' intrinsic at %L shall have the same "
+		 "type as '%s' at %L", gfc_current_intrinsic_arg[val_no]->name,
+		 gfc_current_intrinsic, &value->where,
+		 gfc_current_intrinsic_arg[atom_no]->name, &atom->where);
       return false;
     }
 
+  if (stat != NULL)
+    {
+      if (!type_check (stat, stat_no, BT_INTEGER))
+	return false;
+      if (!scalar_check (stat, stat_no))
+	return false;
+      if (!variable_check (stat, stat_no, false))
+	return false;
+      if (!kind_value_check (stat, stat_no, gfc_default_integer_kind))
+	return false;
+
+      if (!gfc_notify_std (GFC_STD_F2008_TS, "STAT= argument to %s at %L",
+			   gfc_current_intrinsic, &stat->where))
+	return false;
+    }
+
   return true;
 }
 
 
 bool
-gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value)
+gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value, gfc_expr *stat)
 {
   if (atom->expr_type == EXPR_FUNCTION
       && atom->value.function.isym
       && atom->value.function.isym->id == GFC_ISYM_CAF_GET)
     atom = atom->value.function.actual->expr;
 
-  if (!scalar_check (atom, 0) || !scalar_check (value, 1))
-    return false;
-
   if (!gfc_check_vardef_context (atom, false, false, false, NULL))
     {
       gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
@@ -1060,15 +1073,32 @@ gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value)
       return false;
     }
 
-  return gfc_check_atomic (atom, value);
+  return gfc_check_atomic (atom, 0, value, 1, stat, 2);
 }
 
 
 bool
-gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom)
+gfc_check_atomic_op (gfc_expr *atom, gfc_expr *value, gfc_expr *stat)
 {
-  if (!scalar_check (value, 0) || !scalar_check (atom, 1))
-    return false;
+  if (atom->ts.type != BT_INTEGER || atom->ts.kind != gfc_atomic_int_kind)
+    {
+      gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
+		 "integer of ATOMIC_INT_KIND", &atom->where,
+		 gfc_current_intrinsic);
+      return false;
+    }
+
+  return gfc_check_atomic_def (atom, value, stat);
+}
+
+
+bool
+gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom, gfc_expr *stat)
+{
+  if (atom->expr_type == EXPR_FUNCTION
+      && atom->value.function.isym
+      && atom->value.function.isym->id == GFC_ISYM_CAF_GET)
+    atom = atom->value.function.actual->expr;
 
   if (!gfc_check_vardef_context (value, false, false, false, NULL))
     {
@@ -1077,7 +1107,90 @@ gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom)
       return false;
     }
 
-  return gfc_check_atomic (atom, value);
+  return gfc_check_atomic (atom, 1, value, 0, stat, 2);
+}
+
+
+bool
+gfc_check_atomic_cas (gfc_expr *atom, gfc_expr *old, gfc_expr *compare,
+		      gfc_expr *new_val,  gfc_expr *stat)
+{
+  if (atom->expr_type == EXPR_FUNCTION
+      && atom->value.function.isym
+      && atom->value.function.isym->id == GFC_ISYM_CAF_GET)
+    atom = atom->value.function.actual->expr;
+
+  if (!gfc_check_atomic (atom, 0, new_val, 3, stat, 4))
+    return false;
+
+  if (!scalar_check (old, 1) || !scalar_check (compare, 2))
+    return false;
+
+  if (!same_type_check (atom, 0, old, 1))
+    return false;
+
+  if (!same_type_check (atom, 0, compare, 2))
+    return false;
+
+  if (!gfc_check_vardef_context (atom, false, false, false, NULL))
+    {
+      gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
+		 "definable", gfc_current_intrinsic, &atom->where);
+      return false;
+    }
+
+  if (!gfc_check_vardef_context (old, false, false, false, NULL))
+    {
+      gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
+		 "definable", gfc_current_intrinsic, &old->where);
+      return false;
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_atomic_fetch_op (gfc_expr *atom, gfc_expr *value, gfc_expr *old,
+			   gfc_expr *stat)
+{
+  if (atom->expr_type == EXPR_FUNCTION
+      && atom->value.function.isym
+      && atom->value.function.isym->id == GFC_ISYM_CAF_GET)
+    atom = atom->value.function.actual->expr;
+
+  if (atom->ts.type != BT_INTEGER || atom->ts.kind != gfc_atomic_int_kind)
+    {
+      gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
+		 "integer of ATOMIC_INT_KIND", &atom->where,
+		 gfc_current_intrinsic);
+      return false;
+    }
+
+  if (!gfc_check_atomic (atom, 0, value, 1, stat, 3))
+    return false;
+
+  if (!scalar_check (old, 2))
+    return false;
+
+  if (!same_type_check (atom, 0, old, 2))
+    return false;
+
+  if (!gfc_check_vardef_context (atom, false, false, false, NULL))
+    {
+      gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
+		 "definable", gfc_current_intrinsic, &atom->where);
+      return false;
+    }
+
+  if (!gfc_check_vardef_context (old, false, false, false, NULL))
+    {
+      gfc_error ("OLD argument of the %s intrinsic function at %L shall be "
+		 "definable", gfc_current_intrinsic, &old->where);
+      return false;
+    }
+
+  return true;
 }
 
 

gcc/fortran/gfortran.h

@@ -332,8 +332,17 @@ enum gfc_isym_id
   GFC_ISYM_ATAN,
   GFC_ISYM_ATAN2,
   GFC_ISYM_ATANH,
+  GFC_ISYM_ATOMIC_ADD,
+  GFC_ISYM_ATOMIC_AND,
+  GFC_ISYM_ATOMIC_CAS,
   GFC_ISYM_ATOMIC_DEF,
+  GFC_ISYM_ATOMIC_FETCH_ADD,
+  GFC_ISYM_ATOMIC_FETCH_AND,
+  GFC_ISYM_ATOMIC_FETCH_OR,
+  GFC_ISYM_ATOMIC_FETCH_XOR,
+  GFC_ISYM_ATOMIC_OR,
   GFC_ISYM_ATOMIC_REF,
+  GFC_ISYM_ATOMIC_XOR,
   GFC_ISYM_BGE,
   GFC_ISYM_BGT,
   GFC_ISYM_BIT_SIZE,

gcc/fortran/intrinsic.c

@@ -3038,17 +3038,88 @@ add_subroutines (void)
 
   make_noreturn();
 
-  add_sym_2s ("atomic_define", GFC_ISYM_ATOMIC_DEF, CLASS_ATOMIC,
+  add_sym_3s ("atomic_define", GFC_ISYM_ATOMIC_DEF, CLASS_ATOMIC,
 	      BT_UNKNOWN, 0, GFC_STD_F2008,
 	      gfc_check_atomic_def, NULL, gfc_resolve_atomic_def,
 	      "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
-	      "value", BT_INTEGER, di, REQUIRED, INTENT_IN);
+	      "value", BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
 
-  add_sym_2s ("atomic_ref", GFC_ISYM_ATOMIC_REF, CLASS_ATOMIC,
+  add_sym_3s ("atomic_ref", GFC_ISYM_ATOMIC_REF, CLASS_ATOMIC,
 	      BT_UNKNOWN, 0, GFC_STD_F2008,
 	      gfc_check_atomic_ref, NULL, gfc_resolve_atomic_ref,
 	      "value", BT_INTEGER, di, REQUIRED, INTENT_OUT,
-	      "atom", BT_INTEGER, di, REQUIRED, INTENT_IN);
+	      "atom", BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_5s ("atomic_cas", GFC_ISYM_ATOMIC_CAS, CLASS_ATOMIC,
+	      BT_UNKNOWN, 0, GFC_STD_F2008_TS,
+	      gfc_check_atomic_cas, NULL, NULL,
+	      "atom", BT_INTEGER, di, REQUIRED, INTENT_INOUT,
+	      "old", BT_INTEGER, di, REQUIRED, INTENT_OUT,
+	      "compare", BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      "new", BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_3s ("atomic_add", GFC_ISYM_ATOMIC_ADD, CLASS_ATOMIC,
+	      BT_UNKNOWN, 0, GFC_STD_F2008_TS,
+	      gfc_check_atomic_op, NULL, NULL,
+	      "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
+	      "value", BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_3s ("atomic_and", GFC_ISYM_ATOMIC_AND, CLASS_ATOMIC,
+	      BT_UNKNOWN, 0, GFC_STD_F2008_TS,
+	      gfc_check_atomic_op, NULL, NULL,
+	      "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
+	      "value", BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_3s ("atomic_or", GFC_ISYM_ATOMIC_OR, CLASS_ATOMIC,
+	      BT_UNKNOWN, 0, GFC_STD_F2008_TS,
+	      gfc_check_atomic_op, NULL, NULL,
+	      "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
+	      "value", BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_3s ("atomic_xor", GFC_ISYM_ATOMIC_XOR, CLASS_ATOMIC,
+	      BT_UNKNOWN, 0, GFC_STD_F2008_TS,
+	      gfc_check_atomic_op, NULL, NULL,
+	      "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
+	      "value", BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_4s ("atomic_fetch_add", GFC_ISYM_ATOMIC_FETCH_ADD, CLASS_ATOMIC,
+	      BT_UNKNOWN, 0, GFC_STD_F2008_TS,
+	      gfc_check_atomic_fetch_op, NULL, NULL,
+	      "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
+	      "value", BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      "old", BT_INTEGER, di, REQUIRED, INTENT_OUT,
+	      stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_4s ("atomic_fetch_and", GFC_ISYM_ATOMIC_FETCH_AND, CLASS_ATOMIC,
+	      BT_UNKNOWN, 0, GFC_STD_F2008_TS,
+	      gfc_check_atomic_fetch_op, NULL, NULL,
+	      "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
+	      "value", BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      "old", BT_INTEGER, di, REQUIRED, INTENT_OUT,
+	      stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_4s ("atomic_fetch_or", GFC_ISYM_ATOMIC_FETCH_OR, CLASS_ATOMIC,
+	      BT_UNKNOWN, 0, GFC_STD_F2008_TS,
+	      gfc_check_atomic_fetch_op, NULL, NULL,
+	      "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
+	      "value", BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      "old", BT_INTEGER, di, REQUIRED, INTENT_OUT,
+	      stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
+
+  add_sym_4s ("atomic_fetch_xor", GFC_ISYM_ATOMIC_FETCH_XOR, CLASS_ATOMIC,
+	      BT_UNKNOWN, 0, GFC_STD_F2008_TS,
+	      gfc_check_atomic_fetch_op, NULL, NULL,
+	      "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
+	      "value", BT_INTEGER, di, REQUIRED, INTENT_IN,
+	      "old", BT_INTEGER, di, REQUIRED, INTENT_OUT,
+	      stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
 
   add_sym_0s ("backtrace", GFC_ISYM_BACKTRACE, GFC_STD_GNU, NULL);
 

gcc/fortran/intrinsic.h

@@ -38,8 +38,12 @@ bool gfc_check_allocated (gfc_expr *);
 bool gfc_check_associated (gfc_expr *, gfc_expr *);
 bool gfc_check_atan_2 (gfc_expr *, gfc_expr *);
 bool gfc_check_atan2 (gfc_expr *, gfc_expr *);
-bool gfc_check_atomic_def (gfc_expr *, gfc_expr *);
-bool gfc_check_atomic_ref (gfc_expr *, gfc_expr *);
+bool gfc_check_atomic_cas (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
+			   gfc_expr *);
+bool gfc_check_atomic_def (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_atomic_fetch_op (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_atomic_op (gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_atomic_ref (gfc_expr *, gfc_expr *, gfc_expr *);
 bool gfc_check_besn (gfc_expr *, gfc_expr *);
 bool gfc_check_bessel_n2 (gfc_expr *, gfc_expr *, gfc_expr *);
 bool gfc_check_bge_bgt_ble_blt (gfc_expr *, gfc_expr *);

gcc/fortran/iso-fortran-env.def

@@ -85,6 +85,8 @@ NAMED_INTCST (ISOFORTRANENV_FILE_STAT_LOCKED_OTHER_IMAGE, \
 	      GFC_STAT_LOCKED_OTHER_IMAGE, GFC_STD_F2008)
 NAMED_INTCST (ISOFORTRANENV_FILE_STAT_STOPPED_IMAGE, "stat_stopped_image", \
               GFC_STAT_STOPPED_IMAGE, GFC_STD_F2008)
+NAMED_INTCST (ISOFORTRANENV_FILE_STAT_FAILED_IMAGE, "stat_failed_image", \
+              GFC_STAT_FAILED_IMAGE, GFC_STD_F2008_TS)
 NAMED_INTCST (ISOFORTRANENV_FILE_STAT_UNLOCKED, "stat_unlocked", \
               GFC_STAT_UNLOCKED, GFC_STD_F2008)
 

gcc/fortran/libgfortran.h

@@ -115,7 +115,8 @@ typedef enum
   GFC_STAT_UNLOCKED = 0,
   GFC_STAT_LOCKED,
   GFC_STAT_LOCKED_OTHER_IMAGE,
-  GFC_STAT_STOPPED_IMAGE = 6000 /* See LIBERROR_INQUIRE_INTERNAL_UNIT above. */
+  GFC_STAT_STOPPED_IMAGE = 6000, /* See LIBERROR_INQUIRE_INTERNAL_UNIT above. */
+  GFC_STAT_FAILED_IMAGE
 }
 libgfortran_stat_codes;
 

gcc/fortran/trans-intrinsic.c

@@ -8339,25 +8339,104 @@ conv_co_minmaxsum (gfc_code *code)
 
 
 static tree
-conv_intrinsic_atomic_def (gfc_code *code)
+conv_intrinsic_atomic_op (gfc_code *code)
 {
-  gfc_se atom, value;
-  stmtblock_t block;
+  gfc_se atom, value, old;
+  tree tmp;
+  stmtblock_t block, post_block;
   gfc_expr *atom_expr = code->ext.actual->expr;
+  gfc_expr *stat;
+  built_in_function fn;
 
   if (atom_expr->expr_type == EXPR_FUNCTION
       && atom_expr->value.function.isym
       && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
     atom_expr = atom_expr->value.function.actual->expr;
 
+  gfc_start_block (&block);
+  gfc_init_block (&post_block);
   gfc_init_se (&atom, NULL);
   gfc_init_se (&value, NULL);
+  atom.want_pointer = 1;
   gfc_conv_expr (&atom, atom_expr);
+  gfc_add_block_to_block (&block, &atom.pre);
+  gfc_add_block_to_block (&post_block, &atom.post);
   gfc_conv_expr (&value, code->ext.actual->next->expr);
+  gfc_add_block_to_block (&block, &value.pre);
+  gfc_add_block_to_block (&post_block, &value.post);
 
-  gfc_init_block (&block);
-  gfc_add_modify (&block, atom.expr,
-		  fold_convert (TREE_TYPE (atom.expr), value.expr));
+  switch (code->resolved_isym->id)
+    {
+    case GFC_ISYM_ATOMIC_ADD:
+    case GFC_ISYM_ATOMIC_FETCH_ADD:
+      fn = BUILT_IN_ATOMIC_FETCH_ADD_N;
+      break;
+    case GFC_ISYM_ATOMIC_AND:
+    case GFC_ISYM_ATOMIC_FETCH_AND:
+      fn = BUILT_IN_ATOMIC_FETCH_AND_N;
+      break;
+    case GFC_ISYM_ATOMIC_DEF:
+      fn = BUILT_IN_ATOMIC_STORE_N;
+      break;
+    case GFC_ISYM_ATOMIC_OR:
+    case GFC_ISYM_ATOMIC_FETCH_OR:
+      fn = BUILT_IN_ATOMIC_FETCH_OR_N;
+      break;
+    case GFC_ISYM_ATOMIC_XOR:
+    case GFC_ISYM_ATOMIC_FETCH_XOR:
+      fn = BUILT_IN_ATOMIC_FETCH_XOR_N;
+      break;
+    default:
+      gcc_unreachable ();
+    }
+
+  tmp = TREE_TYPE (TREE_TYPE (atom.expr));
+  fn = (built_in_function) ((int) fn
+			    + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
+			    + 1);
+  tmp = builtin_decl_explicit (fn);
+  tree itype = TREE_TYPE (TREE_TYPE (atom.expr));
+  tmp = builtin_decl_explicit (fn);
+
+  switch (code->resolved_isym->id)
+    {
+    case GFC_ISYM_ATOMIC_ADD:
+    case GFC_ISYM_ATOMIC_AND:
+    case GFC_ISYM_ATOMIC_DEF:
+    case GFC_ISYM_ATOMIC_OR:
+    case GFC_ISYM_ATOMIC_XOR:
+      stat = code->ext.actual->next->next->expr;
+      tmp = build_call_expr_loc (input_location, tmp, 3, atom.expr,
+				 fold_convert (itype, value.expr),
+				 build_int_cst (NULL, MEMMODEL_RELAXED));
+      gfc_add_expr_to_block (&block, tmp);
+      break;
+    default:
+      stat = code->ext.actual->next->next->next->expr;
+      gfc_init_se (&old, NULL);
+      gfc_conv_expr (&old, code->ext.actual->next->next->expr);
+      gfc_add_block_to_block (&block, &old.pre);
+      gfc_add_block_to_block (&post_block, &old.post);
+      tmp = build_call_expr_loc (input_location, tmp, 3, atom.expr,
+				 fold_convert (itype, value.expr),
+				 build_int_cst (NULL, MEMMODEL_RELAXED));
+      gfc_add_modify (&block, old.expr,
+		      fold_convert (TREE_TYPE (old.expr), tmp));
+      break;
+    }
+
+  /* STAT=  */
+  if (stat != NULL)
+    {
+      gcc_assert (stat->expr_type == EXPR_VARIABLE);
+      gfc_init_se (&value, NULL);
+      gfc_conv_expr_val (&value, stat);
+      gfc_add_block_to_block (&block, &value.pre);
+      gfc_add_block_to_block (&post_block, &value.post);
+      gfc_add_modify (&block, value.expr,
+		      build_int_cst (TREE_TYPE (value.expr), 0));
+    }
+  gfc_add_block_to_block (&block, &post_block);
   return gfc_finish_block (&block);
 }
 
@@ -8366,22 +8445,124 @@ static tree
 conv_intrinsic_atomic_ref (gfc_code *code)
 {
   gfc_se atom, value;
-  stmtblock_t block;
-  gfc_expr *atom_expr = code->ext.actual->expr;
+  tree tmp;
+  stmtblock_t block, post_block;
+  built_in_function fn;
+  gfc_expr *atom_expr = code->ext.actual->next->expr;
 
   if (atom_expr->expr_type == EXPR_FUNCTION
       && atom_expr->value.function.isym
       && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
     atom_expr = atom_expr->value.function.actual->expr;
 
+  gfc_start_block (&block);
+  gfc_init_block (&post_block);
   gfc_init_se (&atom, NULL);
   gfc_init_se (&value, NULL);
-  gfc_conv_expr (&value, atom_expr);
-  gfc_conv_expr (&atom, code->ext.actual->next->expr);
+  atom.want_pointer = 1;
+  gfc_conv_expr (&value, code->ext.actual->expr);
+  gfc_add_block_to_block (&block, &value.pre);
+  gfc_add_block_to_block (&post_block, &value.post);
+  gfc_conv_expr (&atom, atom_expr);
+  gfc_add_block_to_block (&block, &atom.pre);
+  gfc_add_block_to_block (&post_block, &atom.post);
+
+  tmp = TREE_TYPE (TREE_TYPE (atom.expr));
+  fn = (built_in_function) ((int) BUILT_IN_ATOMIC_LOAD_N
+			    + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
+			    + 1);
+  tmp = builtin_decl_explicit (fn);
+  tmp = build_call_expr_loc (input_location, tmp, 2, atom.expr,
+			     build_int_cst (integer_type_node,
+					    MEMMODEL_RELAXED));
+  gfc_add_modify (&block, value.expr,
+		  fold_convert (TREE_TYPE (value.expr), tmp));
+  
+  /* STAT=  */
+  if (code->ext.actual->next->next->expr != NULL)
+    {
+      gcc_assert (code->ext.actual->next->next->expr->expr_type
+		  == EXPR_VARIABLE);
+      gfc_init_se (&value, NULL);
+      gfc_conv_expr_val (&value, code->ext.actual->next->next->expr);
+      gfc_add_block_to_block (&block, &value.pre);
+      gfc_add_block_to_block (&post_block, &value.post);
+      gfc_add_modify (&block, value.expr,
+		      build_int_cst (TREE_TYPE (value.expr), 0));
+    }
+  gfc_add_block_to_block (&block, &post_block);
+  return gfc_finish_block (&block);
+}
+
+
+static tree
+conv_intrinsic_atomic_cas (gfc_code *code)
+{
+  gfc_se argse;
+  tree tmp, atom, old, new_val, comp;
+  stmtblock_t block, post_block;
+  built_in_function fn;
+  gfc_expr *atom_expr = code->ext.actual->expr;
+
+  if (atom_expr->expr_type == EXPR_FUNCTION
+      && atom_expr->value.function.isym
+      && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
+    atom_expr = atom_expr->value.function.actual->expr;
 
   gfc_init_block (&block);
-  gfc_add_modify (&block, value.expr,
-		  fold_convert (TREE_TYPE (value.expr), atom.expr));
+  gfc_init_block (&post_block);
+  gfc_init_se (&argse, NULL);
+  argse.want_pointer = 1;
+  gfc_conv_expr (&argse, atom_expr);
+  atom = argse.expr;
+
+  gfc_init_se (&argse, NULL);
+  gfc_conv_expr (&argse, code->ext.actual->next->expr);
+  gfc_add_block_to_block (&block, &argse.pre);
+  gfc_add_block_to_block (&post_block, &argse.post);
+  old = argse.expr;
+
+  gfc_init_se (&argse, NULL);
+  gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
+  gfc_add_block_to_block (&block, &argse.pre);
+  gfc_add_block_to_block (&post_block, &argse.post);
+  comp = argse.expr;
+
+  gfc_init_se (&argse, NULL);
+  gfc_conv_expr (&argse, code->ext.actual->next->next->next->expr);
+  gfc_add_block_to_block (&block, &argse.pre);
+  gfc_add_block_to_block (&post_block, &argse.post);
+  new_val = argse.expr;
+
+  tmp = TREE_TYPE (TREE_TYPE (atom));
+  fn = (built_in_function) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
+			    + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
+			    + 1);
+  tmp = builtin_decl_explicit (fn);
+
+  gfc_add_modify (&block, old, comp);
+  tmp = build_call_expr_loc (input_location, tmp, 6, atom,
+			     gfc_build_addr_expr (NULL, old),
+			     fold_convert (TREE_TYPE (old), new_val),
+			     boolean_false_node,
+			     build_int_cst (NULL, MEMMODEL_RELAXED),
+			     build_int_cst (NULL, MEMMODEL_RELAXED));
+  gfc_add_expr_to_block (&block, tmp);
+  
+  /* STAT=  */
+  if (code->ext.actual->next->next->next->next->expr != NULL)
+    {
+      gcc_assert (code->ext.actual->next->next->next->next->expr->expr_type
+		  == EXPR_VARIABLE);
+      gfc_init_se (&argse, NULL);
+      gfc_conv_expr_val (&argse,
+			 code->ext.actual->next->next->next->next->expr);
+      gfc_add_block_to_block (&block, &argse.pre);
+      gfc_add_block_to_block (&post_block, &argse.post);
+      gfc_add_modify (&block, argse.expr,
+		      build_int_cst (TREE_TYPE (argse.expr), 0));
+    }
+  gfc_add_block_to_block (&block, &post_block);
   return gfc_finish_block (&block);
 }
 
@@ -8632,8 +8813,20 @@ gfc_conv_intrinsic_subroutine (gfc_code *code)
       res = conv_intrinsic_move_alloc (code);
       break;
 
+    case GFC_ISYM_ATOMIC_CAS:
+      res = conv_intrinsic_atomic_cas (code);
+      break;
+
+    case GFC_ISYM_ATOMIC_ADD:
+    case GFC_ISYM_ATOMIC_AND:
     case GFC_ISYM_ATOMIC_DEF:
-      res = conv_intrinsic_atomic_def (code);
+    case GFC_ISYM_ATOMIC_OR:
+    case GFC_ISYM_ATOMIC_XOR:
+    case GFC_ISYM_ATOMIC_FETCH_ADD:
+    case GFC_ISYM_ATOMIC_FETCH_AND:
+    case GFC_ISYM_ATOMIC_FETCH_OR:
+    case GFC_ISYM_ATOMIC_FETCH_XOR:
+      res = conv_intrinsic_atomic_op (code);
       break;
 
     case GFC_ISYM_ATOMIC_REF:

gcc/testsuite/ChangeLog

+2014-07-12  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.dg/coarray_atomic_1.f90: Update dg-error.
+	* gfortran.dg/coarray_atomic_2.f90: New.
+	* gfortran.dg/coarray_atomic_3.f90: New.
+	* gfortran.dg/coarray_atomic_4.f90: New.
+	* gfortran.dg/coarray/atomic_2.f90: New.
+
 2014-07-11  Edward Smith-Rowland  <3dw4rd@verizon.net>
 
 	PR c++/57644 - [C++1y] Cannot bind bitfield to lvalue reference

gcc/testsuite/gfortran.dg/coarray_atomic_1.f90

@@ -16,6 +16,6 @@ call atomic_define(a, 7_2) ! { dg-error "must be a scalar" }
 call atomic_ref(b, b) ! { dg-error "shall be a coarray" }
 
 call atomic_define(c, 7) ! { dg-error "an integer of ATOMIC_INT_KIND or a logical of ATOMIC_LOGICAL_KIND" }
-call atomic_ref(d, a(1)) ! { dg-error "shall have the same type" }
+call atomic_ref(d, a(1)) ! { dg-error "shall have the same type as 'atom'" }
 call atomic_ref(.true., e) ! { dg-error "shall be definable" }
 end

gcc/testsuite/gfortran.dg/coarray_atomic_2.f90

+! { dg-do compile }
+! { dg-options "-fcoarray=single -std=f2008" }
+!
+use iso_fortran_env, only: atomic_int_kind, atomic_logical_kind
+implicit none
+
+intrinsic :: atomic_define
+intrinsic :: atomic_ref
+intrinsic :: atomic_cas ! { dg-error "not available in the current standard settings but new in TS 29113/TS 18508." }
+intrinsic :: atomic_add ! { dg-error "not available in the current standard settings but new in TS 29113/TS 18508." }
+intrinsic :: atomic_and ! { dg-error "not available in the current standard settings but new in TS 29113/TS 18508." }
+intrinsic :: atomic_or ! { dg-error "not available in the current standard settings but new in TS 29113/TS 18508." }
+intrinsic :: atomic_xor ! { dg-error "not available in the current standard settings but new in TS 29113/TS 18508." }
+intrinsic :: atomic_fetch_add ! { dg-error "not available in the current standard settings but new in TS 29113/TS 18508." }
+intrinsic :: atomic_fetch_and ! { dg-error "not available in the current standard settings but new in TS 29113/TS 18508." }
+intrinsic :: atomic_fetch_or ! { dg-error "not available in the current standard settings but new in TS 29113/TS 18508." }
+intrinsic :: atomic_fetch_xor ! { dg-error "not available in the current standard settings but new in TS 29113/TS 18508." }
+integer(atomic_int_kind) :: caf[*], var
+logical(atomic_logical_kind) :: caf_log[*], var2
+integer :: stat
+integer(1) :: stat2
+
+call atomic_define(caf, 5, stat=stat) ! { dg-error "STAT= argument to atomic_define" }
+call atomic_define(caf_log, .true., stat=stat2) ! { dg-error "must be of kind 4" }
+call atomic_ref(var, caf[1], stat=stat2) ! { dg-error "must be of kind 4" }
+call atomic_ref(var2, caf_log[1], stat=stat) ! { dg-error "STAT= argument to atomic_ref" }
+end

gcc/testsuite/gfortran.dg/coarray_atomic_3.f90

+! { dg-do compile }
+! { dg-options "-fcoarray=single -std=f2008ts -fmax-errors=200" }
+!
+use iso_fortran_env, only: atomic_int_kind, atomic_logical_kind
+implicit none
+
+intrinsic :: atomic_define
+intrinsic :: atomic_ref
+intrinsic :: atomic_cas
+intrinsic :: atomic_add
+intrinsic :: atomic_and
+intrinsic :: atomic_or
+intrinsic :: atomic_xor
+intrinsic :: atomic_fetch_add
+intrinsic :: atomic_fetch_and
+intrinsic :: atomic_fetch_or
+intrinsic :: atomic_fetch_xor
+integer(atomic_int_kind) :: caf[*], var
+logical(atomic_logical_kind) :: caf_log[*], var2
+integer :: stat
+integer(1) :: var3, caf0[*]
+logical(1) :: var4, caf0_log[*]
+
+call atomic_define(caf[1], 2_2, stat=stat)
+call atomic_define(atom=caf_log[1], value=.false._2)
+call atomic_define(caf_log[1], 2) ! { dg-error "shall have the same type as 'atom'" }
+call atomic_define(var, 2_2, stat=stat) ! { dg-error "shall be a coarray or coindexed" }
+call atomic_define(caf0, 2_2, stat=stat) ! { dg-error "integer of ATOMIC_INT_KIND or a logical of ATOMIC_LOGICAL_KIND" }
+call atomic_define(var2, 2_2, stat=stat) ! { dg-error "shall be a coarray or coindexed" }
+call atomic_define(caf0_log, 2_2, stat=stat) ! { dg-error "integer of ATOMIC_INT_KIND or a logical of ATOMIC_LOGICAL_KIND" }
+
+call atomic_ref(var3, caf[1], stat=stat)
+call atomic_ref(value=var4, atom=caf_log[1])
+call atomic_ref(var, caf_log[1]) ! { dg-error "shall have the same type as 'atom'" }
+call atomic_ref(var, var) ! { dg-error "shall be a coarray or coindexed" }
+call atomic_ref(var, caf0) ! { dg-error "integer of ATOMIC_INT_KIND or a logical of ATOMIC_LOGICAL_KIND" }
+call atomic_ref(var, caf0_log) ! { dg-error "integer of ATOMIC_INT_KIND or a logical of ATOMIC_LOGICAL_KIND" }
+
+call atomic_cas(caf[1], var, 2_4, 1_1, stat=stat)
+call atomic_cas(caf[1], var, 2_2, 1_1, stat=stat) ! { dg-error "'compare' argument of 'atomic_cas' intrinsic at .1. must be the same type and kind as 'atom'" }
+call atomic_cas(caf[1], var3, 2_2, 1_1, stat=stat) ! { dg-error "'old' argument of 'atomic_cas' intrinsic at .1. must be the same type and kind as 'atom'" }
+call atomic_cas(caf[1], var3, 2_4, .false._4, stat=stat) ! { dg-error "shall have the same type as 'atom'" }
+call atomic_cas(caf0[1], var, 2_4, 1_1, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND or a logical of ATOMIC_LOGICAL_KIND" }
+call atomic_cas(var, var, 2_4, 1_1, stat=stat) ! { dg-error "shall be a coarray or coindexed" }
+call atomic_cas(caf_log[1], var2, .true._4, .false._1, stat=stat)
+call atomic_cas(caf_log[1], var2, .true._2, .false._1, stat=stat) ! { dg-error "'compare' argument of 'atomic_cas' intrinsic at .1. must be the same type and kind as 'atom'" }
+call atomic_cas(caf_log[1], var4, .true._4, .false._1, stat=stat) ! { dg-error "'old' argument of 'atomic_cas' intrinsic at .1. must be the same type and kind as 'atom'" }
+call atomic_cas(caf_log[1], var4, .true._4, 4_4, stat=stat) ! { dg-error "shall have the same type as 'atom'" }
+call atomic_cas(atom=caf0_log[1], old=var4, compare=.true._4, new=.false._4, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND or a logical of ATOMIC_LOGICAL_KIND" }
+call atomic_cas(var2, var4, .true._4, .false._4, stat=stat) ! { dg-error "shall be a coarray or coindexed" }
+call atomic_cas(caf[1], var, 2_4, 1_1, stat=var3) ! { dg-error "'stat' argument of 'atomic_cas' intrinsic at .1. must be of kind 4" }
+
+call atomic_add(atom=caf, value=2_4, stat=stat)
+call atomic_add(caf, 2_2, stat=stat)
+call atomic_add(caf, .false._2, stat=stat) ! { dg-error "shall have the same type as 'atom'" }
+call atomic_add(caf_log, .false._2, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND" }
+call atomic_add(var, 34._4) ! { dg-error "shall be a coarray or coindexed" }
+call atomic_add(atom=caf, value=2_4, stat=var3) ! { dg-error "'stat' argument of 'atomic_add' intrinsic at .1. must be of kind 4" }
+
+call atomic_and(caf, 2_4, stat=stat)
+call atomic_and(atom=caf, value=2_2, stat=stat)
+call atomic_and(caf, .false._2, stat=stat) ! { dg-error "shall have the same type as 'atom'" }
+call atomic_and(caf_log, .false._2, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND" }
+call atomic_and(var, 34._4) ! { dg-error "shall be a coarray or coindexed" }
+call atomic_and(caf, 2_4, stat=var3) ! { dg-error "'stat' argument of 'atomic_and' intrinsic at .1. must be of kind 4" }
+
+call atomic_or(caf, value=2_4, stat=stat)
+call atomic_or(atom=caf, value=2_2, stat=stat)
+call atomic_or(caf, .false._2, stat=stat) ! { dg-error "shall have the same type as 'atom'" }
+call atomic_or(caf_log, .false._2, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND" }
+call atomic_or(var, 34._4) ! { dg-error "shall be a coarray or coindexed" }
+call atomic_or(caf, value=2_4, stat=var3) ! { dg-error "'stat' argument of 'atomic_or' intrinsic at .1. must be of kind 4" }
+
+call atomic_xor(caf, 2_4, stat=stat)
+call atomic_xor(atom=caf, value=2_2, stat=stat)
+call atomic_xor(caf, .false._2, stat=stat) ! { dg-error "shall have the same type as 'atom'" }
+call atomic_xor(caf_log, .false._2, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND" }
+call atomic_xor(var, 34._4) ! { dg-error "shall be a coarray or coindexed" }
+call atomic_xor(caf, 2_4, stat=var3) ! { dg-error "'stat' argument of 'atomic_xor' intrinsic at .1. must be of kind 4" }
+
+call atomic_fetch_add(atom=caf, value=2_4, old=var, stat=stat)
+call atomic_fetch_add(caf, 2_2, var)
+call atomic_fetch_add(caf, .false._2, var, stat=stat) ! { dg-error "shall have the same type as 'atom'" }
+call atomic_fetch_add(caf_log, .false._2, var2, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND" }
+call atomic_fetch_add(var, 34._4, var) ! { dg-error "shall be a coarray or coindexed" }
+call atomic_fetch_add(caf, 2_2, var3) ! { dg-error "must be the same type and kind as 'atom'" }
+call atomic_fetch_add(atom=caf, value=2_4, old=var, stat=var3) ! { dg-error "'stat' argument of 'atomic_fetch_add' intrinsic at .1. must be of kind 4" }
+
+call atomic_fetch_and(atom=caf, value=2_4, old=var, stat=stat)
+call atomic_fetch_and(caf, 2_2, var)
+call atomic_fetch_and(caf, .false._2, var, stat=stat) ! { dg-error "shall have the same type as 'atom'" }
+call atomic_fetch_and(caf_log, .false._2, var2, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND" }
+call atomic_fetch_and(var, 34._4, var) ! { dg-error "shall be a coarray or coindexed" }
+call atomic_fetch_and(caf, 2_2, var3) ! { dg-error "must be the same type and kind as 'atom'" }
+call atomic_fetch_and(atom=caf, value=2_4, old=var, stat=var3) ! { dg-error "'stat' argument of 'atomic_fetch_and' intrinsic at .1. must be of kind 4" }
+
+call atomic_fetch_or(atom=caf, value=2_4, old=var, stat=stat)
+call atomic_fetch_or(caf, 2_2, var)
+call atomic_fetch_or(caf, .false._2, var, stat=stat) ! { dg-error "shall have the same type as 'atom'" }
+call atomic_fetch_or(caf_log, .false._2, var2, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND" }
+call atomic_fetch_or(var, 34._4, var) ! { dg-error "shall be a coarray or coindexed" }
+call atomic_fetch_or(caf, 2_2, var3) ! { dg-error "must be the same type and kind as 'atom'" }
+call atomic_fetch_or(atom=caf, value=2_4, old=var, stat=var3) ! { dg-error "'stat' argument of 'atomic_fetch_or' intrinsic at .1. must be of kind 4" }
+
+call atomic_fetch_xor(atom=caf, value=2_4, old=var, stat=stat)
+call atomic_fetch_xor(caf, 2_2, var)
+call atomic_fetch_xor(caf, .false._2, var, stat=stat) ! { dg-error "shall have the same type as 'atom'" }
+call atomic_fetch_xor(caf_log, .false._2, var2, stat=stat) ! { dg-error "shall be an integer of ATOMIC_INT_KIND" }
+call atomic_fetch_xor(var, 34._4, var) ! { dg-error "shall be a coarray or coindexed" }
+call atomic_fetch_xor(caf, 2_2, var3) ! { dg-error "must be the same type and kind as 'atom'" }
+call atomic_fetch_xor(atom=caf, value=2_4, old=var, stat=var3) ! { dg-error "'stat' argument of 'atomic_fetch_xor' intrinsic at .1. must be of kind 4" }
+end

gcc/testsuite/gfortran.dg/coarray_atomic_4.f90

+! { dg-do compile }
+! { dg-options "-fcoarray=single -fdump-tree-original" }
+!
+use iso_fortran_env, only: atomic_int_kind, atomic_logical_kind
+implicit none
+
+intrinsic :: atomic_define
+intrinsic :: atomic_ref
+intrinsic :: atomic_cas
+intrinsic :: atomic_add
+intrinsic :: atomic_and
+intrinsic :: atomic_or
+intrinsic :: atomic_xor
+intrinsic :: atomic_fetch_add
+intrinsic :: atomic_fetch_and
+intrinsic :: atomic_fetch_or
+intrinsic :: atomic_fetch_xor
+integer(atomic_int_kind) :: caf[*], var
+logical(atomic_logical_kind) :: caf_log[*], var2
+integer :: stat
+integer(1) :: var3
+logical(1) :: var4
+
+call atomic_define(caf, var, stat=stat)
+call atomic_define(caf_log, var2, stat=stat)
+
+call atomic_ref(var, caf, stat=stat)
+call atomic_ref(var2, caf_log, stat=stat)
+
+call atomic_cas(caf, var, 3_atomic_int_kind, 5_1, stat=stat)
+call atomic_cas(caf_log, var2, .true._atomic_logical_kind, &
+                .false._2, stat=stat)
+
+call atomic_add(caf, 77, stat=stat)
+call atomic_and(caf, 88, stat=stat)
+call atomic_or(caf, 101, stat=stat)
+call atomic_xor(caf, 105_2, stat=stat)
+
+call atomic_fetch_add(caf, var3, var, stat=stat)
+call atomic_fetch_and(caf, 22_16, var, stat=stat)
+call atomic_fetch_or(caf, var3, var, stat=stat)
+call atomic_fetch_xor(caf, 47_2, var, stat=stat)
+
+end
+
+! All the atomic calls:
+! { dg-final { scan-tree-dump-times "  __atomic_store_4 \\(&caf, \\(integer\\(kind=4\\)\\) var, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "  __atomic_store_4 \\(&caf_log, \\(logical\\(kind=4\\)\\) var2, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "var = \\(integer\\(kind=4\\)\\) __atomic_load_4 \\(&caf, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "var2 = \\(logical\\(kind=4\\)\\) __atomic_load_4 \\(&caf_log, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "  __atomic_compare_exchange_4 \\(&caf, &var, 5, 0, 0, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "  __atomic_compare_exchange_4 \\(&caf_log, &var2, 0, 0, 0, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "  __atomic_fetch_add_4 \\(&caf, 77, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "  __atomic_fetch_and_4 \\(&caf, 88, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "  __atomic_fetch_or_4 \\(&caf, 101, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "  __atomic_fetch_xor_4 \\(&caf, 105, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "var = \\(integer\\(kind=4\\)\\) __atomic_fetch_add_4 \\(&caf, \\(integer\\(kind=4\\)\\) var3, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "var = \\(integer\\(kind=4\\)\\) __atomic_fetch_and_4 \\(&caf, 22, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "  var = \\(integer\\(kind=4\\)\\) __atomic_fetch_or_4 \\(&caf, \\(integer\\(kind=4\\)\\) var3, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "  var = \\(integer\\(kind=4\\)\\) __atomic_fetch_xor_4 \\(&caf, 47, 0\\);" 1 "original" } }
+
+! CAS: Handle "compare" argument
+! { dg-final { scan-tree-dump-times "var = 3;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "var2 = 1;" 1 "original" } }
+
+! All calls should have a stat=0
+! { dg-final { scan-tree-dump-times "stat = 0;" 14 "original" } }
+
+! { dg-final { cleanup-tree-dump "original" } }