+2011-05-31 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/18918
+ * intrinsic.c (klass): Add CLASS_ATOMIC.
+ (add_subroutines): Add atomic_ref/atomic_define.
+ * intrinsic.texi (ATOMIC_REF, ATOMIC_DEFINE): Document.
+ * intrinsic.h (gfc_check_atomic_def, gfc_check_atomic_ref,
+ gfc_resolve_atomic_def, gfc_resolve_atomic_ref): New prototypes.
+ * gfortran.h (gfc_isym_id): Add GFC_ISYM_ATOMIC_DEF
+ and GFC_ISYM_ATOMIC_REF.
+ (gfc_atomic_int_kind, gfc_atomic_logical_kind): New global vars.
+ * iresolve.c (gfc_resolve_atomic_def, gfc_resolve_atomic_ref): New
+ functions.
+ * check.c (gfc_check_atomic, gfc_check_atomic_def,
+ gfc_check_atomic_ref): New functions.
+ * iso-fortran-env.def (ISOFORTRANENV_FILE_ATOMIC_INT_KIND,
+ ISOFORTRANENV_FILE_ATOMIC_LOGICAL_KIND): Change kind value.
+ * trans-intrinsic.c (conv_intrinsic_atomic_def,
+ conv_intrinsic_atomic_ref, gfc_conv_intrinsic_subroutine): New
+ functions.
+ (conv_intrinsic_move_alloc) Renamed from
+ gfc_conv_intrinsic_move_alloc - and made static.
+ * trans.h (gfc_conv_intrinsic_move_alloc): Remove.
+ (gfc_conv_intrinsic_subroutine) Add prototype.
+ * trans.c (trans_code): Call gfc_conv_intrinsic_subroutine.
+ * trans-types (gfc_atomic_int_kind, gfc_atomic_logical_kind): New
+ global vars.
+ (gfc_init_kinds): Set them.
+
2011-05-31 Tobias Burnus <burnus@net-b.de>
PR fortran/18918
}
+static gfc_try
+gfc_check_atomic (gfc_expr *atom, gfc_expr *value)
+{
+ if (!(atom->ts.type == BT_INTEGER && atom->ts.kind == gfc_atomic_int_kind)
+ && !(atom->ts.type == BT_LOGICAL
+ && atom->ts.kind == gfc_atomic_logical_kind))
+ {
+ gfc_error ("ATOM argument at %L to intrinsic function %s shall be an "
+ "integer of ATOMIC_INT_KIND or a logical of "
+ "ATOMIC_LOGICAL_KIND", &atom->where, gfc_current_intrinsic);
+ return FAILURE;
+ }
+
+ if (!gfc_expr_attr (atom).codimension)
+ {
+ gfc_error ("ATOM argument at %L of the %s intrinsic function shall be a "
+ "coarray or coindexed", &atom->where, gfc_current_intrinsic);
+ return FAILURE;
+ }
+
+ 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);
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_atomic_def (gfc_expr *atom, gfc_expr *value)
+{
+ if (scalar_check (atom, 0) == FAILURE || scalar_check (value, 1) == FAILURE)
+ return FAILURE;
+
+ if (gfc_check_vardef_context (atom, false, NULL) == FAILURE)
+ {
+ gfc_error ("ATOM argument of the %s intrinsic function at %L shall be "
+ "definable", gfc_current_intrinsic, &atom->where);
+ return FAILURE;
+ }
+
+ return gfc_check_atomic (atom, value);
+}
+
+
+gfc_try
+gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom)
+{
+ if (scalar_check (value, 0) == FAILURE || scalar_check (atom, 1) == FAILURE)
+ return FAILURE;
+
+ if (gfc_check_vardef_context (value, false, NULL) == FAILURE)
+ {
+ gfc_error ("VALUE argument of the %s intrinsic function at %L shall be "
+ "definable", gfc_current_intrinsic, &value->where);
+ return FAILURE;
+ }
+
+ return gfc_check_atomic (atom, value);
+}
+
+
/* BESJN and BESYN functions. */
gfc_try
GFC_ISYM_ATAN,
GFC_ISYM_ATAN2,
GFC_ISYM_ATANH,
+ GFC_ISYM_ATOMIC_DEF,
+ GFC_ISYM_ATOMIC_REF,
GFC_ISYM_BGE,
GFC_ISYM_BGT,
GFC_ISYM_BIT_SIZE,
extern int gfc_default_logical_kind;
extern int gfc_default_complex_kind;
extern int gfc_c_int_kind;
+extern int gfc_atomic_int_kind;
+extern int gfc_atomic_logical_kind;
extern int gfc_intio_kind;
extern int gfc_charlen_int_kind;
extern int gfc_numeric_storage_size;
enum klass
{ CLASS_IMPURE = 0, CLASS_PURE, CLASS_ELEMENTAL,
- CLASS_INQUIRY, CLASS_TRANSFORMATIONAL };
+ CLASS_INQUIRY, CLASS_TRANSFORMATIONAL, CLASS_ATOMIC };
#define ACTUAL_NO 0
#define ACTUAL_YES 1
make_noreturn();
+ add_sym_2s ("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);
+
+ add_sym_2s ("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);
+
add_sym_1s ("cpu_time", GFC_ISYM_CPU_TIME, CLASS_IMPURE, BT_UNKNOWN, 0,
GFC_STD_F95, gfc_check_cpu_time, NULL, gfc_resolve_cpu_time,
tm, BT_REAL, dr, REQUIRED, INTENT_OUT);
gfc_try gfc_check_associated (gfc_expr *, gfc_expr *);
gfc_try gfc_check_atan_2 (gfc_expr *, gfc_expr *);
gfc_try gfc_check_atan2 (gfc_expr *, gfc_expr *);
+gfc_try gfc_check_atomic_def (gfc_expr *, gfc_expr *);
+gfc_try gfc_check_atomic_ref (gfc_expr *, gfc_expr *);
gfc_try gfc_check_besn (gfc_expr *, gfc_expr *);
gfc_try gfc_check_bessel_n2 (gfc_expr *, gfc_expr *, gfc_expr *);
gfc_try gfc_check_bge_bgt_ble_blt (gfc_expr *, gfc_expr *);
void gfc_resolve_atan (gfc_expr *, gfc_expr *);
void gfc_resolve_atanh (gfc_expr *, gfc_expr *);
void gfc_resolve_atan2 (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_atomic_def (gfc_code *);
+void gfc_resolve_atomic_ref (gfc_code *);
void gfc_resolve_besn (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_bessel_n2 (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *a);
void gfc_resolve_btest (gfc_expr *, gfc_expr *, gfc_expr *);
* @code{ATAN}: ATAN, Arctangent function
* @code{ATAN2}: ATAN2, Arctangent function
* @code{ATANH}: ATANH, Inverse hyperbolic tangent function
+* @code{ATOMIC_DEFINE}: ATOMIC_DEFINE, Setting a variable atomically
+* @code{ATOMIC_REF}: ATOMIC_REF, Obtaining the value of a variable atomically
* @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
* @code{BESSEL_JN}: BESSEL_JN, Bessel function of the first kind
+@node ATOMIC_DEFINE
+@section @code{ATOMIC_DEFINE} --- Setting a variable atomically
+@fnindex ATOMIC_DEFINE
+@cindex Atomic subroutine, define
+
+@table @asis
+@item @emph{Description}:
+@code{ATOMIC_DEFINE(ATOM, VALUE)} defines the variable @var{ATOM} with the value
+@var{VALUE} atomically.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Atomic subroutine
+
+@item @emph{Syntax}:
+@code{CALL ATOMIC_DEFINE(ATOM, VALUE)}
+
+@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}.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+program atomic
+ use iso_fortran_env
+ integer(atomic_int_kind) :: atom[*]
+ call atomic_define (atom[1], this_image())
+end program atomic
+@end smallexample
+
+@item @emph{See also}:
+@ref{ATOMIC_REF}, @ref{ISO_FORTRAN_ENV}
+@end table
+
+
+
+@node ATOMIC_REF
+@section @code{ATOMIC_REF} --- Obtaining the value of a variable atomically
+@fnindex ATOMIC_REF
+@cindex Atomic subroutine, reference
+
+@table @asis
+@item @emph{Description}:
+@code{ATOMIC_DEFINE(ATOM, VALUE)} atomically assigns the value of the
+variable @var{ATOM} to @var{VALUE}.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Atomic subroutine
+
+@item @emph{Syntax}:
+@code{CALL ATOMIC_REF(VALUE, ATOM)}
+
+@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{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.
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+program atomic
+ use iso_fortran_env
+ logical(atomic_logical_kind) :: atom[*]
+ logical :: val
+ call atomic_ref (atom, .false.)
+ ! ...
+ call atomic_ref (atom, val)
+ if (val) then
+ print *, "Obtained"
+ end if
+end program atomic
+@end smallexample
+
+@item @emph{See also}:
+@ref{ATOMIC_DEFINE}, @ref{ISO_FORTRAN_ENV}
+@end table
+
+
+
@node BESSEL_J0
@section @code{BESSEL_J0} --- Bessel function of the first kind of order 0
@fnindex BESSEL_J0
}
+void
+gfc_resolve_atomic_def (gfc_code *c)
+{
+ const char *name = "atomic_define";
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
+void
+gfc_resolve_atomic_ref (gfc_code *c)
+{
+ const char *name = "atomic_ref";
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
+
void
gfc_resolve_mvbits (gfc_code *c)
{
-- the standard that supports this type */
NAMED_INTCST (ISOFORTRANENV_FILE_ATOMIC_INT_KIND, "atomic_int_kind", \
- gfc_default_integer_kind, GFC_STD_F2008)
+ gfc_atomic_int_kind, GFC_STD_F2008)
NAMED_INTCST (ISOFORTRANENV_FILE_ATOMIC_LOGICAL_KIND, "atomic_logical_kind", \
- gfc_default_logical_kind, GFC_STD_F2008)
+ gfc_atomic_logical_kind, GFC_STD_F2008)
NAMED_INTCST (ISOFORTRANENV_CHARACTER_STORAGE_SIZE, "character_storage_size", \
gfc_character_storage_size, GFC_STD_F2003)
NAMED_INTCST (ISOFORTRANENV_ERROR_UNIT, "error_unit", GFC_STDERR_UNIT_NUMBER, \
}
-tree
-gfc_conv_intrinsic_move_alloc (gfc_code *code)
+static tree
+conv_intrinsic_atomic_def (gfc_code *code)
+{
+ gfc_se atom, value;
+ stmtblock_t block;
+
+ gfc_init_se (&atom, NULL);
+ gfc_init_se (&value, NULL);
+ gfc_conv_expr (&atom, code->ext.actual->expr);
+ gfc_conv_expr (&value, code->ext.actual->next->expr);
+
+ gfc_init_block (&block);
+ gfc_add_modify (&block, atom.expr,
+ fold_convert (TREE_TYPE (atom.expr), value.expr));
+ return gfc_finish_block (&block);
+}
+
+
+static tree
+conv_intrinsic_atomic_ref (gfc_code *code)
+{
+ gfc_se atom, value;
+ stmtblock_t block;
+
+ gfc_init_se (&atom, NULL);
+ gfc_init_se (&value, NULL);
+ gfc_conv_expr (&value, code->ext.actual->expr);
+ gfc_conv_expr (&atom, code->ext.actual->next->expr);
+
+ gfc_init_block (&block);
+ gfc_add_modify (&block, value.expr,
+ fold_convert (TREE_TYPE (value.expr), atom.expr));
+ return gfc_finish_block (&block);
+}
+
+
+static tree
+conv_intrinsic_move_alloc (gfc_code *code)
{
if (code->ext.actual->expr->rank == 0)
{
}
+tree
+gfc_conv_intrinsic_subroutine (gfc_code *code)
+{
+ tree res;
+
+ gcc_assert (code->resolved_isym);
+
+ switch (code->resolved_isym->id)
+ {
+ case GFC_ISYM_MOVE_ALLOC:
+ res = conv_intrinsic_move_alloc (code);
+ break;
+
+ case GFC_ISYM_ATOMIC_DEF:
+ res = conv_intrinsic_atomic_def (code);
+ break;
+
+ case GFC_ISYM_ATOMIC_REF:
+ res = conv_intrinsic_atomic_ref (code);
+ break;
+
+ default:
+ res = NULL_TREE;
+ break;
+ }
+
+ return res;
+}
+
#include "gt-fortran-trans-intrinsic.h"
int gfc_default_logical_kind;
int gfc_default_complex_kind;
int gfc_c_int_kind;
+int gfc_atomic_int_kind;
+int gfc_atomic_logical_kind;
/* The kind size used for record offsets. If the target system supports
kind=8, this will be set to 8, otherwise it is set to 4. */
/* Pick a kind the same size as the C "int" type. */
gfc_c_int_kind = INT_TYPE_SIZE / 8;
+ /* Choose atomic kinds to match C's int. */
+ gfc_atomic_int_kind = gfc_c_int_kind;
+ gfc_atomic_logical_kind = gfc_c_int_kind;
+
/* initialize the C interoperable kinds */
init_c_interop_kinds();
}
dependency check, too. */
{
bool is_mvbits = false;
+
+ if (code->resolved_isym)
+ {
+ res = gfc_conv_intrinsic_subroutine (code);
+ if (res != NULL_TREE)
+ break;
+ }
+
if (code->resolved_isym
&& code->resolved_isym->id == GFC_ISYM_MVBITS)
is_mvbits = true;
- if (code->resolved_isym
- && code->resolved_isym->id == GFC_ISYM_MOVE_ALLOC)
- res = gfc_conv_intrinsic_move_alloc (code);
- else
- res = gfc_trans_call (code, is_mvbits, NULL_TREE,
- NULL_TREE, false);
+
+ res = gfc_trans_call (code, is_mvbits, NULL_TREE,
+ NULL_TREE, false);
}
break;
/* Find the appropriate variant of a math intrinsic. */
tree gfc_builtin_decl_for_float_kind (enum built_in_function, int);
-/* Intrinsic function handling. */
+/* Intrinsic procedure handling. */
+tree gfc_conv_intrinsic_subroutine (gfc_code *);
void gfc_conv_intrinsic_function (gfc_se *, gfc_expr *);
/* Is the intrinsic expanded inline. */
gfc_inline_intrinsic_function_p returns true. */
int gfc_is_intrinsic_libcall (gfc_expr *);
-tree gfc_conv_intrinsic_move_alloc (gfc_code *);
-
/* Used to call ordinary functions/subroutines
and procedure pointer components. */
int gfc_conv_procedure_call (gfc_se *, gfc_symbol *, gfc_actual_arglist *,
+2011-05-31 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/18918
+ * gfortran.dg/coarray_atomic_1.f90: New.
+ * gfortran.dg/coarray/atomic_1.f90: New.
+
2011-05-31 Jakub Jelinek <jakub@redhat.com>
* gcc.dg/guality/bswaptest.c: New test.
--- /dev/null
+! { dg-do run }
+!
+! PR fortran/18918
+!
+! Basic atomic def/ref test
+!
+
+use iso_fortran_env, only: atomic_int_kind, atomic_logical_kind
+implicit none
+integer(atomic_int_kind) :: a(1)[*]
+logical(atomic_logical_kind) :: c[*]
+intrinsic :: atomic_define
+intrinsic :: atomic_ref
+integer(8) :: b
+logical(1) :: d
+
+call atomic_define(a(1), 7_2)
+call atomic_ref(b, a(1))
+if (b /= a(1)) call abort()
+
+call atomic_define(c, .false.)
+call atomic_ref(d, c[this_image()])
+if (d .neqv. .false.) call abort()
+call atomic_define(c[this_image()], .true.)
+call atomic_ref(d, c)
+if (d .neqv. .true.) call abort()
+end
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fcoarray=single -std=f2008" }
+!
+! PR fortran/18918
+!
+! Diagnostic for atomic subroutines
+!
+use iso_fortran_env, only: atomic_int_kind, atomic_logical_kind
+implicit none
+integer(atomic_int_kind) :: a(1)[*]
+logical(1) :: c[*]
+integer(atomic_int_kind) :: b
+logical(atomic_logical_kind) :: d, e[*]
+
+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(.true., e) ! { dg-error "shall be definable" }
+end
projects / gcc.git / commitdiff