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

1 files changed, 130 insertions, 17 deletions

diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 10944eb..eff2c4c 100644
--- a/gcc/fortran/check.c
+++ b/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;
 }