From: Tobias Burnus <burnus@net-b.de>
To: gcc-patches <gcc-patches@gcc.gnu.org>, gfortran <fortran@gcc.gnu.org>
Subject: [Patch, Fortran] Update atomics support for TS18508
Date: Fri, 11 Jul 2014 21:30:00 -0000 [thread overview]
Message-ID: <53C0576A.3080001@net-b.de> (raw)
[-- Attachment #1: Type: text/plain, Size: 1084 bytes --]
This patch updates the atomic support for TS18508, namely:
– The atomic intrinsics now take a STAT= argument
– Add the new atomics atomic_{add,and,or,xor} and their fetch variants
atomic_fetch_{add,and,or,xor} – and compare and swap (atomic_cas)
In addition, the previous implementation (for -fcoarray=single) used
simple assignments; the patch changes those to using real atomic
operations, which makes the atomic operations thread safe.
Build and regtested on x86-64-gnu-linux.
OK for the trunk?
As next step, library calls have to be added for -fcoarray=lib. For
coarrays, I also a have still on my to do list: Adding a type-conversion
test case for -fcorray=lib; implementing in the library the support for
vector subscripts; and fixing an issue with nonallocatable polymorphic
dummy coarrays and select type.
For full F2008 support, the following is needed as well: locking and
critical blocks – and allocatable/pointer components of derived types.
For TS18508 much more is needed, in particular co_reduce/co_broadcast
and team support.
Tobias
[-- Attachment #2: atomic.diff --]
[-- Type: text/x-patch, Size: 78719 bytes --]
gcc/fortran/
2014-07-10 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-10 Tobias Burnus <burnus@net-b.de>
* gfortran.dg/coarray/atomic_2.f90: New.
* gfortran.dg/coarray_atomic_1.f90: New.
* gfortran.dg/coarray_atomic_2.f90: New.
* gfortran.dg/coarray_atomic_3.f90: New.
* gfortran.dg/coarray_atomic_4.f90: New.
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;
}
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 3481319..f1750da 100644
--- a/gcc/fortran/gfortran.h
+++ b/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,
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index bf784b5..d681d70 100644
--- a/gcc/fortran/intrinsic.c
+++ b/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);
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index 05cd146..9437171 100644
--- a/gcc/fortran/intrinsic.h
+++ b/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 *);
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index 87f6478..2cf6dfe 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/gcc/fortran/intrinsic.texi
@@ -60,8 +60,17 @@ Some basic guidelines for editing this document:
* @code{ATAN}: ATAN, Arctangent function
* @code{ATAN2}: ATAN2, Arctangent function
* @code{ATANH}: ATANH, Inverse hyperbolic tangent function
+* @code{ATOMIC_ADD}: ATOMIC_ADD, Atomic ADD operation
+* @code{ATOMIC_AND}: ATOMIC_AND, Atomic bitwise AND operation
+* @code{ATOMIC_CAS}: ATOMIC_CAS, Atomic compare and swap
+* @code{ATOMIC_FETCH_ADD}: ATOMIC_FETCH_ADD, Atomic ADD operation with prior fetch
+* @code{ATOMIC_FETCH_AND}: ATOMIC_FETCH_AND, Atomic bitwise AND operation with prior fetch
+* @code{ATOMIC_FETCH_OR}: ATOMIC_FETCH_OR, Atomic bitwise OR operation with prior fetch
+* @code{ATOMIC_FETCH_XOR}: ATOMIC_FETCH_XOR, Atomic bitwise XOR operation with prior fetch
+* @code{ATOMIC_OR}: ATOMIC_OR, Atomic bitwise OR operation
* @code{ATOMIC_DEFINE}: ATOMIC_DEFINE, Setting a variable atomically
* @code{ATOMIC_REF}: ATOMIC_REF, Obtaining the value of a variable atomically
+* @code{ATOMIC_XOR}: ATOMIC_XOR, Atomic bitwise OR operation
* @code{BACKTRACE}: BACKTRACE, Show a backtrace
* @code{BESSEL_J0}: BESSEL_J0, Bessel function of the first kind of order 0
* @code{BESSEL_J1}: BESSEL_J1, Bessel function of the first kind of order 1
@@ -1554,6 +1563,159 @@ Inverse function: @ref{TANH}
+@node ATOMIC_ADD
+@section @code{ATOMIC_ADD} --- Atomic ADD operation
+@fnindex ATOMIC_ADD
+@cindex Atomic subroutine, add
+
+@table @asis
+@item @emph{Description}:
+@code{ATOMIC_ADD(ATOM, VALUE)} atomically adds the value of @var{VAR} to the
+variable @var{ATOM}. When @var{STAT} is present and the invokation was
+successful, it is assigned the value 0. If it is present and the invokation
+has failed, it is assigned a positive value; in particular, for a coindexed
+@var{ATOM}, if the remote image has stopped, it is assigned the value of
+@code{ISO_FORTRAN_ENV}'s @code{STAT_STOPPED_IMAGE} and if the remote image has
+failed, the value @code{STAT_FAILED_IMAGE}.
+
+@item @emph{Standard}:
+TS 18508 or later
+
+@item @emph{Class}:
+Atomic subroutine
+
+@item @emph{Syntax}:
+@code{CALL ATOMIC_ADD (ATOM, VALUE [, STAT])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ATOM} @tab Scalar coarray or coindexed variable of integer
+type with @code{ATOMIC_INT_KIND} kind.
+@item @var{VALUE} @tab Scalar of the same type as @var{ATOM}. If the kind
+is different, the value is converted to the kind of @var{ATOM}.
+@item @var{STAT} @tab (optional) Scalar default-kind integer variable.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+program atomic
+ use iso_fortran_env
+ integer(atomic_int_kind) :: atom[*]
+ call atomic_add (atom[1], this_image())
+end program atomic
+@end smallexample
+
+@item @emph{See also}:
+@ref{ATOMIC_DEFINE}, @ref{ATOMIC_FETCH_ADD}, @ref{ISO_FORTRAN_ENV},
+@ref{ATOMIC_AND}, @ref{ATOMIC_OR}, @ref{ATOMIC_XOR}
+@end table
+
+
+
+
+@node ATOMIC_AND
+@section @code{ATOMIC_AND} --- Atomic bitwise AND operation
+@fnindex ATOMIC_AND
+@cindex Atomic subroutine, AND
+
+@table @asis
+@item @emph{Description}:
+@code{ATOMIC_AND(ATOM, VALUE)} atomically defines @var{ATOM} with the bitwise
+AND between the values of @var{ATOM} and @var{VALUE}. When @var{STAT} is present
+and the invokation was successful, it is assigned the value 0. If it is present
+and the invokation has failed, it is assigned a positive value; in particular,
+for a coindexed @var{ATOM}, if the remote image has stopped, it is assigned the
+value of @code{ISO_FORTRAN_ENV}'s @code{STAT_STOPPED_IMAGE} and if the remote
+image has failed, the value @code{STAT_FAILED_IMAGE}.
+
+@item @emph{Standard}:
+TS 18508 or later
+
+@item @emph{Class}:
+Atomic subroutine
+
+@item @emph{Syntax}:
+@code{CALL ATOMIC_AND (ATOM, VALUE [, STAT])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ATOM} @tab Scalar coarray or coindexed variable of integer
+type with @code{ATOMIC_INT_KIND} kind.
+@item @var{VALUE} @tab Scalar of the same type as @var{ATOM}. If the kind
+is different, the value is converted to the kind of @var{ATOM}.
+@item @var{STAT} @tab (optional) Scalar default-kind integer variable.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+program atomic
+ use iso_fortran_env
+ integer(atomic_int_kind) :: atom[*]
+ call atomic_and (atom[1], int(b'10100011101'))
+end program atomic
+@end smallexample
+
+@item @emph{See also}:
+@ref{ATOMIC_DEFINE}, @ref{ATOMIC_FETCH_AND}, @ref{ISO_FORTRAN_ENV},
+@ref{ATOMIC_ADD}, @ref{ATOMIC_OR}, @ref{ATOMIC_XOR}
+@end table
+
+
+
+@node ATOMIC_CAS
+@section @code{ATOMIC_CAS} --- Atomic compare and swap
+@fnindex ATOMIC_DEFINE
+@cindex Atomic subroutine, compare and swap
+
+@table @asis
+@item @emph{Description}:
+@code{ATOMIC_CAS} compares the variable @var{ATOM} with the value of
+@var{COMPARE}; if the value is the same, @var{ATOM} is set to the value
+of @var{NEW}. Additionally, @var{OLD} is set to the value of @var{ATOM}
+that was used for the comparison. When @var{STAT} is present and the invokation
+was successful, it is assigned the value 0. If it is present and the invokation
+has failed, it is assigned a positive value; in particular, for a coindexed
+@var{ATOM}, if the remote image has stopped, it is assigned the value of
+@code{ISO_FORTRAN_ENV}'s @code{STAT_STOPPED_IMAGE} and if the remote image has
+failed, the value @code{STAT_FAILED_IMAGE}.
+
+@item @emph{Standard}:
+TS 18508 or later
+
+@item @emph{Class}:
+Atomic subroutine
+
+@item @emph{Syntax}:
+@code{CALL ATOMIC_CAS (ATOM, OLD, COMPARE, NEW [, STAT])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ATOM} @tab Scalar coarray or coindexed variable of either integer
+type with @code{ATOMIC_INT_KIND} kind or logical type with
+@code{ATOMIC_LOGICAL_KIND} kind.
+@item @var{OLD} @tab Scalar of the same type and kind as @var{ATOM}.
+@item @var{COMPARE} @tab Scalar variable of the same type and kind as
+@var{ATOM}.
+@item @var{NEW} @tab Scalar variable of the same type as @var{ATOM}. If kind
+is different, the value is converted to the kind of @var{ATOM}.
+@item @var{STAT} @tab (optional) Scalar default-kind integer variable.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+program atomic
+ use iso_fortran_env
+ logical(atomic_logical_kind) :: atom[*], prev
+ call atomic_cas (atom[1], prev, .false., .true.))
+end program atomic
+@end smallexample
+
+@item @emph{See also}:
+@ref{ATOMIC_DEFINE}, @ref{ATOMIC_REF}, @ref{ISO_FORTRAN_ENV}
+@end table
+
+
+
@node ATOMIC_DEFINE
@section @code{ATOMIC_DEFINE} --- Setting a variable atomically
@fnindex ATOMIC_DEFINE
@@ -1562,25 +1724,31 @@ Inverse function: @ref{TANH}
@table @asis
@item @emph{Description}:
@code{ATOMIC_DEFINE(ATOM, VALUE)} defines the variable @var{ATOM} with the value
-@var{VALUE} atomically.
+@var{VALUE} atomically. When @var{STAT} is present and the invokation was
+successful, it is assigned the value 0. If it is present and the invokation
+has failed, it is assigned a positive value; in particular, for a coindexed
+@var{ATOM}, if the remote image has stopped, it is assigned the value of
+@code{ISO_FORTRAN_ENV}'s @code{STAT_STOPPED_IMAGE} and if the remote image has
+failed, the value @code{STAT_FAILED_IMAGE}.
@item @emph{Standard}:
-Fortran 2008 and later
+Fortran 2008 and later; with @var{STAT}, TS 18508 or later
@item @emph{Class}:
Atomic subroutine
@item @emph{Syntax}:
-@code{CALL ATOMIC_DEFINE(ATOM, VALUE)}
+@code{CALL ATOMIC_DEFINE (ATOM, VALUE [, STAT])}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{ATOM} @tab Scalar coarray or coindexed variable of either integer
- type with @code{ATOMIC_INT_KIND} kind or logical type
- with @code{ATOMIC_LOGICAL_KIND} kind.
-@item @var{VALURE} @tab Scalar and of the same type as @var{ATOM}. If the kind
- is different, the value is converted to the kind of
- @var{ATOM}.
+type with @code{ATOMIC_INT_KIND} kind or logical type with
+@code{ATOMIC_LOGICAL_KIND} kind.
+
+@item @var{VALUE} @tab Scalar of the same type as @var{ATOM}. If the kind
+is different, the value is converted to the kind of @var{ATOM}.
+@item @var{STAT} @tab (optional) Scalar default-kind integer variable.
@end multitable
@item @emph{Example}:
@@ -1593,7 +1761,263 @@ end program atomic
@end smallexample
@item @emph{See also}:
-@ref{ATOMIC_REF}, @ref{ISO_FORTRAN_ENV}
+@ref{ATOMIC_REF}, @ref{ATOMIC_CAS}, @ref{ISO_FORTRAN_ENV},
+@ref{ATOMIC_ADD}, @ref{ATOMIC_AND}, @ref{ATOMIC_OR}, @ref{ATOMIC_XOR}
+@end table
+
+
+
+@node ATOMIC_FETCH_ADD
+@section @code{ATOMIC_FETCH_ADD} --- Atomic ADD operation with prior fetch
+@fnindex ATOMIC_FETCH_ADD
+@cindex Atomic subroutine, ADD with fetch
+
+@table @asis
+@item @emph{Description}:
+@code{ATOMIC_FETCH_ADD(ATOM, VALUE, OLD)} atomically stores the value of
+@var{ATOM} in @var{OLD} and adds the value of @var{VAR} to the
+variable @var{ATOM}. When @var{STAT} is present and the invokation was
+successful, it is assigned the value 0. If it is present and the invokation
+has failed, it is assigned a positive value; in particular, for a coindexed
+@var{ATOM}, if the remote image has stopped, it is assigned the value of
+@code{ISO_FORTRAN_ENV}'s @code{STAT_STOPPED_IMAGE} and if the remote image has
+failed, the value @code{STAT_FAILED_IMAGE}.
+
+@item @emph{Standard}:
+TS 18508 or later
+
+@item @emph{Class}:
+Atomic subroutine
+
+@item @emph{Syntax}:
+@code{CALL ATOMIC_FETCH_ADD (ATOM, VALUE, old [, STAT])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ATOM} @tab Scalar coarray or coindexed variable of integer
+type with @code{ATOMIC_INT_KIND} kind.
+@code{ATOMIC_LOGICAL_KIND} kind.
+
+@item @var{VALUE} @tab Scalar of the same type as @var{ATOM}. If the kind
+is different, the value is converted to the kind of @var{ATOM}.
+@item @var{OLD} @tab Scalar of the same type and kind as @var{ATOM}.
+@item @var{STAT} @tab (optional) Scalar default-kind integer variable.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+program atomic
+ use iso_fortran_env
+ integer(atomic_int_kind) :: atom[*], old
+ call atomic_add (atom[1], this_image(), old)
+end program atomic
+@end smallexample
+
+@item @emph{See also}:
+@ref{ATOMIC_DEFINE}, @ref{ATOMIC_ADD}, @ref{ISO_FORTRAN_ENV},
+@ref{ATOMIC_FETCH_AND}, @ref{ATOMIC_FETCH_OR}, @ref{ATOMIC_FETCH_XOR}
+@end table
+
+
+
+@node ATOMIC_FETCH_AND
+@section @code{ATOMIC_FETCH_AND} --- Atomic bitwise AND operation with prior fetch
+@fnindex ATOMIC_FETCH_AND
+@cindex Atomic subroutine, AND with fetch
+
+@table @asis
+@item @emph{Description}:
+@code{ATOMIC_AND(ATOM, VALUE)} atomically stores the value of @var{ATOM} in
+@var{OLD} and defines @var{ATOM} with the bitwise AND between the values of
+@var{ATOM} and @var{VALUE}. When @var{STAT} is present and the invokation was
+successful, it is assigned the value 0. If it is present and the invokation has
+failed, it is assigned a positive value; in particular, for a coindexed
+@var{ATOM}, if the remote image has stopped, it is assigned the value of
+@code{ISO_FORTRAN_ENV}'s @code{STAT_STOPPED_IMAGE} and if the remote image has
+failed, the value @code{STAT_FAILED_IMAGE}.
+
+@item @emph{Standard}:
+TS 18508 or later
+
+@item @emph{Class}:
+Atomic subroutine
+
+@item @emph{Syntax}:
+@code{CALL ATOMIC_FETCH_AND (ATOM, VALUE, OLD [, STAT])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ATOM} @tab Scalar coarray or coindexed variable of integer
+type with @code{ATOMIC_INT_KIND} kind.
+@item @var{VALUE} @tab Scalar of the same type as @var{ATOM}. If the kind
+is different, the value is converted to the kind of @var{ATOM}.
+@item @var{OLD} @tab Scalar of the same type and kind as @var{ATOM}.
+@item @var{STAT} @tab (optional) Scalar default-kind integer variable.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+program atomic
+ use iso_fortran_env
+ integer(atomic_int_kind) :: atom[*], old
+ call atomic_fetch_and (atom[1], int(b'10100011101'), old)
+end program atomic
+@end smallexample
+
+@item @emph{See also}:
+@ref{ATOMIC_DEFINE}, @ref{ATOMIC_AND}, @ref{ISO_FORTRAN_ENV},
+@ref{ATOMIC_FETCH_ADD}, @ref{ATOMIC_FETCH_OR}, @ref{ATOMIC_FETCH_XOR}
+@end table
+
+
+
+@node ATOMIC_FETCH_OR
+@section @code{ATOMIC_FETCH_OR} --- Atomic bitwise OR operation with prior fetch
+@fnindex ATOMIC_FETCH_OR
+@cindex Atomic subroutine, OR with fetch
+
+@table @asis
+@item @emph{Description}:
+@code{ATOMIC_OR(ATOM, VALUE)} atomically stores the value of @var{ATOM} in
+@var{OLD} and defines @var{ATOM} with the bitwise OR between the values of
+@var{ATOM} and @var{VALUE}. When @var{STAT} is present and the invokation was
+successful, it is assigned the value 0. If it is present and the invokation has
+failed, it is assigned a positive value; in particular, for a coindexed
+@var{ATOM}, if the remote image has stopped, it is assigned the value of
+@code{ISO_FORTRAN_ENV}'s @code{STAT_STOPPED_IMAGE} and if the remote image has
+failed, the value @code{STAT_FAILED_IMAGE}.
+
+@item @emph{Standard}:
+TS 18508 or later
+
+@item @emph{Class}:
+Atomic subroutine
+
+@item @emph{Syntax}:
+@code{CALL ATOMIC_FETCH_OR (ATOM, VALUE, OLD [, STAT])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ATOM} @tab Scalar coarray or coindexed variable of integer
+type with @code{ATOMIC_INT_KIND} kind.
+@item @var{VALUE} @tab Scalar of the same type as @var{ATOM}. If the kind
+is different, the value is converted to the kind of @var{ATOM}.
+@item @var{OLD} @tab Scalar of the same type and kind as @var{ATOM}.
+@item @var{STAT} @tab (optional) Scalar default-kind integer variable.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+program atomic
+ use iso_fortran_env
+ integer(atomic_int_kind) :: atom[*], old
+ call atomic_fetch_or (atom[1], int(b'10100011101'), old)
+end program atomic
+@end smallexample
+
+@item @emph{See also}:
+@ref{ATOMIC_DEFINE}, @ref{ATOMIC_OR}, @ref{ISO_FORTRAN_ENV},
+@ref{ATOMIC_FETCH_ADD}, @ref{ATOMIC_FETCH_AND}, @ref{ATOMIC_FETCH_XOR}
+@end table
+
+
+
+@node ATOMIC_FETCH_XOR
+@section @code{ATOMIC_FETCH_XOR} --- Atomic bitwise XOR operation with prior fetch
+@fnindex ATOMIC_FETCH_XOR
+@cindex Atomic subroutine, XOR with fetch
+
+@table @asis
+@item @emph{Description}:
+@code{ATOMIC_XOR(ATOM, VALUE)} atomically stores the value of @var{ATOM} in
+@var{OLD} and defines @var{ATOM} with the bitwise XOR between the values of
+@var{ATOM} and @var{VALUE}. When @var{STAT} is present and the invokation was
+successful, it is assigned the value 0. If it is present and the invokation has
+failed, it is assigned a positive value; in particular, for a coindexed
+@var{ATOM}, if the remote image has stopped, it is assigned the value of
+@code{ISO_FORTRAN_ENV}'s @code{STAT_STOPPED_IMAGE} and if the remote image has
+failed, the value @code{STAT_FAILED_IMAGE}.
+
+@item @emph{Standard}:
+TS 18508 or later
+
+@item @emph{Class}:
+Atomic subroutine
+
+@item @emph{Syntax}:
+@code{CALL ATOMIC_FETCH_XOR (ATOM, VALUE, OLD [, STAT])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ATOM} @tab Scalar coarray or coindexed variable of integer
+type with @code{ATOMIC_INT_KIND} kind.
+@item @var{VALUE} @tab Scalar of the same type as @var{ATOM}. If the kind
+is different, the value is converted to the kind of @var{ATOM}.
+@item @var{OLD} @tab Scalar of the same type and kind as @var{ATOM}.
+@item @var{STAT} @tab (optional) Scalar default-kind integer variable.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+program atomic
+ use iso_fortran_env
+ integer(atomic_int_kind) :: atom[*], old
+ call atomic_fetch_xor (atom[1], int(b'10100011101'), old)
+end program atomic
+@end smallexample
+
+@item @emph{See also}:
+@ref{ATOMIC_DEFINE}, @ref{ATOMIC_XOR}, @ref{ISO_FORTRAN_ENV},
+@ref{ATOMIC_FETCH_ADD}, @ref{ATOMIC_FETCH_AND}, @ref{ATOMIC_FETCH_OR}
+@end table
+
+
+
+@node ATOMIC_OR
+@section @code{ATOMIC_OR} --- Atomic bitwise OR operation
+@fnindex ATOMIC_OR
+@cindex Atomic subroutine, OR
+
+@table @asis
+@item @emph{Description}:
+@code{ATOMIC_OR(ATOM, VALUE)} atomically defines @var{ATOM} with the bitwise
+AND between the values of @var{ATOM} and @var{VALUE}. When @var{STAT} is present
+and the invokation was successful, it is assigned the value 0. If it is present
+and the invokation has failed, it is assigned a positive value; in particular,
+for a coindexed @var{ATOM}, if the remote image has stopped, it is assigned the
+value of @code{ISO_FORTRAN_ENV}'s @code{STAT_STOPPED_IMAGE} and if the remote
+image has failed, the value @code{STAT_FAILED_IMAGE}.
+
+@item @emph{Standard}:
+TS 18508 or later
+
+@item @emph{Class}:
+Atomic subroutine
+
+@item @emph{Syntax}:
+@code{CALL ATOMIC_OR (ATOM, VALUE [, STAT])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ATOM} @tab Scalar coarray or coindexed variable of integer
+type with @code{ATOMIC_INT_KIND} kind.
+@item @var{VALUE} @tab Scalar of the same type as @var{ATOM}. If the kind
+is different, the value is converted to the kind of @var{ATOM}.
+@item @var{STAT} @tab (optional) Scalar default-kind integer variable.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+program atomic
+ use iso_fortran_env
+ integer(atomic_int_kind) :: atom[*]
+ call atomic_or (atom[1], int(b'10100011101'))
+end program atomic
+@end smallexample
+
+@item @emph{See also}:
+@ref{ATOMIC_DEFINE}, @ref{ATOMIC_FETCH_OR}, @ref{ISO_FORTRAN_ENV},
+@ref{ATOMIC_ADD}, @ref{ATOMIC_OR}, @ref{ATOMIC_XOR}
@end table
@@ -1606,25 +2030,31 @@ end program atomic
@table @asis
@item @emph{Description}:
@code{ATOMIC_DEFINE(ATOM, VALUE)} atomically assigns the value of the
-variable @var{ATOM} to @var{VALUE}.
+variable @var{ATOM} to @var{VALUE}. When @var{STAT} is present and the
+invokation was successful, it is assigned the value 0. If it is present and the
+invokation has failed, it is assigned a positive value; in particular, for a
+coindexed @var{ATOM}, if the remote image has stopped, it is assigned the value
+of @code{ISO_FORTRAN_ENV}'s @code{STAT_STOPPED_IMAGE} and if the remote image
+has failed, the value @code{STAT_FAILED_IMAGE}.
+
@item @emph{Standard}:
-Fortran 2008 and later
+Fortran 2008 and later; with @var{STAT}, TS 18508 or later
@item @emph{Class}:
Atomic subroutine
@item @emph{Syntax}:
-@code{CALL ATOMIC_REF(VALUE, ATOM)}
+@code{CALL ATOMIC_REF(VALUE, ATOM [, STAT])}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
-@item @var{VALURE} @tab Scalar and of the same type as @var{ATOM}. If the kind
- is different, the value is converted to the kind of
- @var{ATOM}.
+@item @var{VALUE} @tab Scalar of the same type as @var{ATOM}. If the kind
+is different, the value is converted to the kind of @var{ATOM}.
@item @var{ATOM} @tab Scalar coarray or coindexed variable of either integer
- type with @code{ATOMIC_INT_KIND} kind or logical type
- with @code{ATOMIC_LOGICAL_KIND} kind.
+type with @code{ATOMIC_INT_KIND} kind or logical type with
+@code{ATOMIC_LOGICAL_KIND} kind.
+@item @var{STAT} @tab (optional) Scalar default-kind integer variable.
@end multitable
@item @emph{Example}:
@@ -1643,10 +2073,59 @@ end program atomic
@end smallexample
@item @emph{See also}:
-@ref{ATOMIC_DEFINE}, @ref{ISO_FORTRAN_ENV}
+@ref{ATOMIC_DEFINE}, @ref{ATOMIC_CAS}, @ref{ISO_FORTRAN_ENV},
+@ref{ATOMIC_FETCH_ADD}, @ref{ATOMIC_FETCH_AND}, @ref{ATOMIC_FETCH_OR},
+@ref{ATOMIC_FETCH_XOR}
@end table
+@node ATOMIC_XOR
+@section @code{ATOMIC_XOR} --- Atomic bitwise OR operation
+@fnindex ATOMIC_XOR
+@cindex Atomic subroutine, XOR
+
+@table @asis
+@item @emph{Description}:
+@code{ATOMIC_AND(ATOM, VALUE)} atomically defines @var{ATOM} with the bitwise
+XOR between the values of @var{ATOM} and @var{VALUE}. When @var{STAT} is present
+and the invokation was successful, it is assigned the value 0. If it is present
+and the invokation has failed, it is assigned a positive value; in particular,
+for a coindexed @var{ATOM}, if the remote image has stopped, it is assigned the
+value of @code{ISO_FORTRAN_ENV}'s @code{STAT_STOPPED_IMAGE} and if the remote
+image has failed, the value @code{STAT_FAILED_IMAGE}.
+
+@item @emph{Standard}:
+TS 18508 or later
+
+@item @emph{Class}:
+Atomic subroutine
+
+@item @emph{Syntax}:
+@code{CALL ATOMIC_XOR (ATOM, VALUE [, STAT])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ATOM} @tab Scalar coarray or coindexed variable of integer
+type with @code{ATOMIC_INT_KIND} kind.
+@item @var{VALUE} @tab Scalar of the same type as @var{ATOM}. If the kind
+is different, the value is converted to the kind of @var{ATOM}.
+@item @var{STAT} @tab (optional) Scalar default-kind integer variable.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+program atomic
+ use iso_fortran_env
+ integer(atomic_int_kind) :: atom[*]
+ call atomic_xor (atom[1], int(b'10100011101'))
+end program atomic
+@end smallexample
+
+@item @emph{See also}:
+@ref{ATOMIC_DEFINE}, @ref{ATOMIC_FETCH_XOR}, @ref{ISO_FORTRAN_ENV},
+@ref{ATOMIC_ADD}, @ref{ATOMIC_OR}, @ref{ATOMIC_XOR}
+@end table
+
@node BACKTRACE
@section @code{BACKTRACE} --- Show a backtrace
@@ -13252,6 +13731,11 @@ Positive, scalar default-integer constant used as STAT= return value if the
argument in the statement requires synchronisation with an image, which has
initiated the termination of the execution. (Fortran 2008 or later.)
+@item @code{STAT_FAILED_IMAGE}:
+Positive, scalar default-integer constant used as STAT= return value if the
+argument in the statement requires communication with an image, which has
+is in the failed state. (TS 18508 or later.)
+
@item @code{STAT_UNLOCKED}:
Scalar default-integer constant used as STAT= return value by @code{UNLOCK} to
denote that the lock variable is unlocked. (Fortran 2008 or later.)
diff --git a/gcc/fortran/iso-fortran-env.def b/gcc/fortran/iso-fortran-env.def
index ebadaef..c1d990a 100644
--- a/gcc/fortran/iso-fortran-env.def
+++ b/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)
diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h
index 1f8616f..b90dac6 100644
--- a/gcc/fortran/libgfortran.h
+++ b/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;
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 5aa5683..a285e9d 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/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:
diff --git a/gcc/testsuite/gfortran.dg/coarray/atomic_2.f90 b/gcc/testsuite/gfortran.dg/coarray/atomic_2.f90
new file mode 100644
index 0000000..20b6890
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/atomic_2.f90
@@ -0,0 +1,653 @@
+! { dg-do run }
+!
+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, var3
+logical(atomic_logical_kind) :: caf_log[*], var2
+integer :: stat, i
+
+caf = 0
+caf_log = .false.
+sync all
+
+if (this_image() == 1) then
+ call atomic_define(caf[num_images()], 5, stat=stat)
+ if (stat /= 0) call abort()
+ call atomic_define(caf_log[num_images()], .true., stat=stat)
+ if (stat /= 0) call abort()
+end if
+sync all
+
+if (this_image() == num_images()) then
+ if (caf /= 5) call abort()
+ if (.not. caf_log) call abort()
+ var = 99
+ call atomic_ref(var, caf, stat=stat)
+ if (stat /= 0 .or. var /= 5) call abort()
+ var2 = .false.
+ call atomic_ref(var2, caf_log, stat=stat)
+ if (stat /= 0 .or. .not. var2) call abort()
+end if
+call atomic_ref(var, caf[num_images()], stat=stat)
+if (stat /= 0 .or. var /= 5) call abort()
+call atomic_ref(var2, caf_log[num_images()], stat=stat)
+if (stat /= 0 .or. .not. var2) call abort()
+sync all
+
+! ADD
+caf = 0
+sync all
+
+call atomic_add(caf, this_image(), stat=stat)
+if (stat /= 0) call abort()
+do i = 1, num_images()
+ call atomic_add(caf[i], 1, stat=stat)
+ if (stat /= 0) call abort()
+ call atomic_ref(var, caf, stat=stat)
+ if (stat /= 0 .or. var < this_image()) call abort()
+end do
+sync all
+
+call atomic_ref(var, caf[num_images()], stat=stat)
+if (stat /= 0 .or. var /= num_images() + this_image()) call abort()
+do i = 1, num_images()
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= num_images() + i) call abort()
+end do
+sync all
+
+! AND(1)
+caf = 0
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ do i = this_image(), min(num_images(), storage_size(caf)-2)
+ call atomic_and(caf[i], shiftl(1, this_image()), stat=stat)
+ if (stat /= 0) call abort()
+ end do
+end if
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ var3 = 0
+ do i = 1, min(num_images(), storage_size(caf)-2)
+ var3 = iand(var3, shiftl(1, i))
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ if (i == this_image()) then
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ end if
+ end do
+end if
+sync all
+
+! AND(2)
+caf = -1
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ do i = this_image(), min(num_images(), storage_size(caf)-2)
+ call atomic_and(caf[i], shiftl(1, this_image()), stat=stat)
+ if (stat /= 0) call abort()
+ end do
+end if
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ var3 = -1
+ do i = 1, min(num_images(), storage_size(caf)-2)
+ var3 = iand(var3, shiftl(1, i))
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ if (i == this_image()) then
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ end if
+ end do
+end if
+sync all
+
+! AND(3)
+caf = 0
+do i = 1, storage_size(caf)-2, 2
+ caf = shiftl(1, i)
+ var3 = shiftl(1, i)
+end do
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ do i = this_image(), min(num_images(), storage_size(caf)-2)
+ call atomic_and(caf[i], shiftl(1, this_image()), stat=stat)
+ if (stat /= 0) call abort()
+ end do
+end if
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ do i = 1, min(num_images(), storage_size(caf)-2)
+ var3 = iand(var3, shiftl(1, i))
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ if (i == this_image()) then
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ end if
+ end do
+end if
+sync all
+
+! OR(1)
+caf = 0
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ do i = this_image(), min(num_images(), storage_size(caf)-2)
+ call atomic_or(caf[i], shiftl(1, this_image()), stat=stat)
+ if (stat /= 0) call abort()
+ end do
+end if
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ var3 = 0
+ do i = 1, min(num_images(), storage_size(caf)-2)
+ var3 = ior(var3, shiftl(1, i))
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ if (i == this_image()) then
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ end if
+ end do
+end if
+sync all
+
+! OR(2)
+caf = -1
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ do i = this_image(), min(num_images(), storage_size(caf)-2)
+ call atomic_or(caf[i], shiftl(1, this_image()), stat=stat)
+ if (stat /= 0) call abort()
+ end do
+end if
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ var3 = -1
+ do i = 1, min(num_images(), storage_size(caf)-2)
+ var3 = ior(var3, shiftl(1, i))
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ if (i == this_image()) then
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ end if
+ end do
+end if
+sync all
+
+! OR(3)
+caf = 0
+do i = 1, storage_size(caf)-2, 2
+ caf = shiftl(1, i)
+ var3 = shiftl(1, i)
+end do
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ do i = this_image(), min(num_images(), storage_size(caf)-2)
+ call atomic_or(caf[i], shiftl(1, this_image()), stat=stat)
+ if (stat /= 0) call abort()
+ end do
+end if
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ do i = 1, min(num_images(), storage_size(caf)-2)
+ var3 = ior(var3, shiftl(1, i))
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ if (i == this_image()) then
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ end if
+ end do
+end if
+sync all
+
+! XOR(1)
+caf = 0
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ do i = this_image(), min(num_images(), storage_size(caf)-2)
+ call atomic_xor(caf[i], shiftl(1, this_image()), stat=stat)
+ if (stat /= 0) call abort()
+ end do
+end if
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ var3 = 0
+ do i = 1, min(num_images(), storage_size(caf)-2)
+ var3 = ieor(var3, shiftl(1, i))
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ if (i == this_image()) then
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ end if
+ end do
+end if
+sync all
+
+! XOR(2)
+caf = -1
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ do i = this_image(), min(num_images(), storage_size(caf)-2)
+ call atomic_xor(caf[i], shiftl(1, this_image()), stat=stat)
+ if (stat /= 0) call abort()
+ end do
+end if
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ var3 = -1
+ do i = 1, min(num_images(), storage_size(caf)-2)
+ var3 = ieor(var3, shiftl(1, i))
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ if (i == this_image()) then
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ end if
+ end do
+end if
+sync all
+
+! XOR(3)
+caf = 0
+do i = 1, storage_size(caf)-2, 2
+ caf = shiftl(1, i)
+ var3 = shiftl(1, i)
+end do
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ do i = this_image(), min(num_images(), storage_size(caf)-2)
+ call atomic_xor(caf[i], shiftl(1, this_image()), stat=stat)
+ if (stat /= 0) call abort()
+ end do
+end if
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ do i = 1, min(num_images(), storage_size(caf)-2)
+ var3 = ieor(var3, shiftl(1, i))
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ if (i == this_image()) then
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ end if
+ end do
+end if
+sync all
+
+! ADD
+caf = 0
+sync all
+var = -99
+call atomic_fetch_add(caf, this_image(), var, stat=stat)
+if (stat /= 0 .or. var < 0) call abort()
+if (num_images() == 1 .and. var /= 0) call abort()
+do i = 1, num_images()
+ var = -99
+ call atomic_fetch_add(caf[i], 1, var, stat=stat)
+ if (stat /= 0 .or. var < 0) call abort()
+ call atomic_ref(var, caf, stat=stat)
+ if (stat /= 0 .or. var < this_image()) call abort()
+end do
+sync all
+
+call atomic_ref(var, caf[num_images()], stat=stat)
+if (stat /= 0 .or. var /= num_images() + this_image()) call abort()
+do i = 1, num_images()
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= num_images() + i) call abort()
+end do
+sync all
+
+
+! AND(1)
+caf = 0
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ do i = this_image(), min(num_images(), storage_size(caf)-2)
+ var = 99
+ call atomic_fetch_and(caf[i], shiftl(1, this_image()), var, stat=stat)
+ if (stat /= 0 .or. var /= 0) call abort()
+ end do
+end if
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ var3 = 0
+ do i = 1, min(num_images(), storage_size(caf)-2)
+ var3 = iand(var3, shiftl(1, i))
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ if (i == this_image()) then
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ end if
+ end do
+end if
+sync all
+
+! AND(2)
+caf = -1
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ do i = this_image(), min(num_images(), storage_size(caf)-2)
+ var = -99
+ call atomic_fetch_and(caf[i], shiftl(1, this_image()), var, stat=stat)
+ if (stat /= 0 .or. var == shiftl(1, this_image())) call abort()
+ end do
+end if
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ var3 = -1
+ do i = 1, min(num_images(), storage_size(caf)-2)
+ var3 = iand(var3, shiftl(1, i))
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ if (i == this_image()) then
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ end if
+ end do
+end if
+sync all
+
+! AND(3)
+caf = 0
+var3 = 0
+do i = 1, storage_size(caf)-2, 2
+ caf = ior(shiftl(1, i), caf)
+ var3 = ior(shiftl(1, i), var3)
+end do
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ do i = this_image(), min(num_images(), storage_size(caf)-2)
+ var = -99
+ call atomic_fetch_and(caf[i], shiftl(1, this_image()), var, stat=stat)
+ if (stat /= 0 .or. var <= 0) call abort()
+ end do
+end if
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ do i = 1, min(num_images(), storage_size(caf)-2)
+ var3 = iand(var3, shiftl(1, i))
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ if (i == this_image()) then
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ end if
+ end do
+end if
+sync all
+
+
+
+! OR(1)
+caf = 0
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ do i = this_image(), min(num_images(), storage_size(caf)-2)
+ var = -99
+ call atomic_fetch_or(caf[i], shiftl(1, this_image()), var, stat=stat)
+ if (stat /= 0 .or. var < 0 .or. var == shiftl(1, this_image())) call abort()
+ end do
+end if
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ var3 = 0
+ do i = 1, min(num_images(), storage_size(caf)-2)
+ var3 = ior(var3, shiftl(1, i))
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ if (i == this_image()) then
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ end if
+ end do
+end if
+sync all
+
+! OR(2)
+caf = -1
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ do i = this_image(), min(num_images(), storage_size(caf)-2)
+ var = -99
+ call atomic_fetch_or(caf[i], shiftl(1, this_image()), var, stat=stat)
+ if (stat /= 0 .or. (var < 0 .and. var /= -1)) call abort()
+ end do
+end if
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ var3 = -1
+ do i = 1, min(num_images(), storage_size(caf)-2)
+ var3 = ior(var3, shiftl(1, i))
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ if (i == this_image()) then
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ end if
+ end do
+end if
+sync all
+
+! OR(3)
+caf = 0
+var3 = 0
+do i = 1, storage_size(caf)-2, 2
+ caf = ior(shiftl(1, i), caf)
+ var3 = ior(shiftl(1, i), var3)
+end do
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ do i = this_image(), min(num_images(), storage_size(caf)-2)
+ var = -99
+ call atomic_fetch_or(caf[i], shiftl(1, this_image()), var, stat=stat)
+ if (stat /= 0 .or. var <= 0) call abort()
+ end do
+end if
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ do i = 1, min(num_images(), storage_size(caf)-2)
+ var3 = ior(var3, shiftl(1, i))
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ if (i == this_image()) then
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ end if
+ end do
+end if
+sync all
+
+
+! XOR(1)
+caf = 0
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ do i = this_image(), min(num_images(), storage_size(caf)-2)
+ var = -99
+ call atomic_fetch_xor(caf[i], shiftl(1, this_image()), var, stat=stat)
+ if (stat /= 0 .or. var < 0 .or. var == shiftl(1, this_image())) call abort()
+ end do
+end if
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ var3 = 0
+ do i = 1, min(num_images(), storage_size(caf)-2)
+ var3 = ieor(var3, shiftl(1, i))
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ if (i == this_image()) then
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ end if
+ end do
+end if
+sync all
+
+! XOR(2)
+caf = -1
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ do i = this_image(), min(num_images(), storage_size(caf)-2)
+ var = -99
+ call atomic_fetch_xor(caf[i], shiftl(1, this_image()), var, stat=stat)
+ if (stat /= 0 .or. (var < 0 .and. var /= -1)) call abort()
+ end do
+end if
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ var3 = -1
+ do i = 1, min(num_images(), storage_size(caf)-2)
+ var3 = ieor(var3, shiftl(1, i))
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ if (i == this_image()) then
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ end if
+ end do
+end if
+sync all
+
+! XOR(3)
+caf = 0
+var3 = 0
+do i = 1, storage_size(caf)-2, 2
+ caf = ior(shiftl(1, i), caf)
+ var3 = ior(shiftl(1, i), var3)
+end do
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ do i = this_image(), min(num_images(), storage_size(caf)-2)
+ var = -99
+ call atomic_fetch_xor(caf[i], shiftl(1, this_image()), var, stat=stat)
+ if (stat /= 0 .or. var <= 0) call abort()
+ end do
+end if
+sync all
+
+if (this_image() < storage_size(caf)-2) then
+ do i = 1, min(num_images(), storage_size(caf)-2)
+ var3 = ieor(var3, shiftl(1, i))
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ if (i == this_image()) then
+ call atomic_ref(var, caf[i], stat=stat)
+ if (stat /= 0 .or. var /= var3) call abort()
+ end if
+ end do
+end if
+sync all
+
+! CAS
+caf = 9
+caf_log = .true.
+sync all
+
+if (this_image() == 1) then
+ call atomic_cas(caf[num_images()], compare=5, new=3, old=var, stat=stat)
+ if (stat /= 0 .or. var /= 9) call abort()
+ call atomic_ref(var, caf[num_images()], stat=stat)
+ if (stat /= 0 .or. var /= 9) call abort()
+end if
+sync all
+
+if (this_image() == num_images() .and. caf /= 9) call abort()
+call atomic_ref(var, caf[num_images()], stat=stat)
+if (stat /= 0 .or. var /= 9) call abort()
+sync all
+
+if (this_image() == 1) then
+ call atomic_cas(caf[num_images()], compare=9, new=3, old=var, stat=stat)
+ if (stat /= 0 .or. var /= 9) call abort()
+ call atomic_ref(var, caf[num_images()], stat=stat)
+ if (stat /= 0 .or. var /= 3) call abort()
+end if
+sync all
+
+if (this_image() == num_images() .and. caf /= 3) call abort()
+call atomic_ref(var, caf[num_images()], stat=stat)
+if (stat /= 0 .or. var /= 3) call abort()
+sync all
+
+
+if (this_image() == 1) then
+ call atomic_cas(caf_log[num_images()], compare=.false., new=.false., old=var2, stat=stat)
+ if (stat /= 0 .or. var2 .neqv. .true.) call abort()
+ call atomic_ref(var2, caf_log[num_images()], stat=stat)
+ if (stat /= 0 .or. var2 .neqv. .true.) call abort()
+end if
+sync all
+
+if (this_image() == num_images() .and. caf_log .neqv. .true.) call abort()
+call atomic_ref(var2, caf_log[num_images()], stat=stat)
+if (stat /= 0 .or. var2 .neqv. .true.) call abort()
+sync all
+
+if (this_image() == 1) then
+ call atomic_cas(caf_log[num_images()], compare=.true., new=.false., old=var2, stat=stat)
+ if (stat /= 0 .or. var2 .neqv. .true.) call abort()
+ call atomic_ref(var2, caf_log[num_images()], stat=stat)
+ if (stat /= 0 .or. var2 .neqv. .false.) call abort()
+end if
+sync all
+
+if (this_image() == num_images() .and. caf_log .neqv. .false.) call abort()
+call atomic_ref(var2, caf_log[num_images()], stat=stat)
+if (stat /= 0 .or. var2 .neqv. .false.) call abort()
+end
diff --git a/gcc/testsuite/gfortran.dg/coarray_atomic_1.f90 b/gcc/testsuite/gfortran.dg/coarray_atomic_1.f90
index bf94b91..107f076 100644
--- a/gcc/testsuite/gfortran.dg/coarray_atomic_1.f90
+++ b/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
diff --git a/gcc/testsuite/gfortran.dg/coarray_atomic_2.f90 b/gcc/testsuite/gfortran.dg/coarray_atomic_2.f90
new file mode 100644
index 0000000..c66827b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_atomic_2.f90
@@ -0,0 +1,27 @@
+! { 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
diff --git a/gcc/testsuite/gfortran.dg/coarray_atomic_3.f90 b/gcc/testsuite/gfortran.dg/coarray_atomic_3.f90
new file mode 100644
index 0000000..a3c4264
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_atomic_3.f90
@@ -0,0 +1,112 @@
+! { 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
diff --git a/gcc/testsuite/gfortran.dg/coarray_atomic_4.f90 b/gcc/testsuite/gfortran.dg/coarray_atomic_4.f90
new file mode 100644
index 0000000..663a6c8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_atomic_4.f90
@@ -0,0 +1,69 @@
+! { 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" } }
next reply other threads:[~2014-07-11 21:30 UTC|newest]
Thread overview: 4+ messages / expand[flat|nested] mbox.gz Atom feed top
2014-07-11 21:30 Tobias Burnus [this message]
2014-07-12 18:44 ` Paul Richard Thomas
2014-07-13 7:58 ` Andreas Schwab
2014-07-13 7:53 Dominique Dhumieres
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=53C0576A.3080001@net-b.de \
--to=burnus@net-b.de \
--cc=fortran@gcc.gnu.org \
--cc=gcc-patches@gcc.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).