procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

check.c (positive_check): Add new function checking constant for being greater then zero.

Browse source 
gcc/fortran/ChangeLog:

2017-03-05  Andre Vehreschild  <vehre@gcc.gnu.org>
            Alessandro Fanfarillo  <fanfarillo.gcc@gmail.com>

	* check.c (positive_check): Add new function checking constant for
	being greater then zero.
	(gfc_check_image_status): Add checking of image_status arguments.
	(gfc_check_failed_or_stopped_images): Same but for failed_- and
	stopped_images function.
	* dump-parse-tree.c (show_code_node): Added output of FAIL IMAGE.
	* gfortran.h (enum gfc_statement): Added FAIL_IMAGE_ST.
	(enum gfc_isym_id): Added new intrinsic symbols.
	(enum gfc_exec_op): Added EXEC_FAIL_IMAGE.
	* gfortran.texi: Added description for the new API functions. Updated
	coverage of gfortran of TS18508.
	* intrinsic.c (add_functions): Added symbols to resolve new intrinsic
	functions. 
	* intrinsic.h: Added prototypes.
	* iresolve.c (gfc_resolve_failed_images): Resolve the failed_images
	intrinsic.
	(gfc_resolve_image_status): Same for image_status.
	(gfc_resolve_stopped_images): Same for stopped_images.
	* libgfortran.h: Added prototypes.
	* match.c (gfc_match_if): Added matching of FAIL IMAGE statement.
	(gfc_match_fail_image): Match a FAIL IMAGE statement.
	* match.h: Added prototype.
	* parse.c (decode_statement): Added matching for FAIL IMAGE.
	(next_statement): Same.
	(gfc_ascii_statement): Same.
	* resolve.c: Same.
	* simplify.c (gfc_simplify_failed_or_stopped_images): For COARRAY=
	single a constant result can be returne.d
	(gfc_simplify_image_status): For COARRAY=single the result is constant.
	* st.c (gfc_free_statement): Added FAIL_IMAGE handling.
	* trans-decl.c (gfc_build_builtin_function_decls): Added decls of the
	new intrinsics.
	* trans-expr.c (gfc_conv_procedure_call): This is first time all
	arguments of a function are optional, which is now handled here
	correctly.
	* trans-intrinsic.c (conv_intrinsic_image_status): Translate
	image_status.
	(gfc_conv_intrinsic_function): Add support for image_status.
	(gfc_is_intrinsic_libcall): Add support for the remaining new
	intrinsics.
	* trans-stmt.c (gfc_trans_fail_image): Trans a fail image.
	* trans-stmt.h: Add the prototype for the above.
	* trans.c (trans_code): Dispatch for fail_image.
	* trans.h: Add the trees for the new intrinsics.

libgfortran/ChangeLog:

2017-03-05  Andre Vehreschild  <vehre@gcc.gnu.org>
            Alessandro Fanfarillo  <fanfarillo.gcc@gmail.com>

	* caf/libcaf.h: Added prototypes and stat codes for failed and stopped
	images.
	* caf/single.c (void _gfortran_caf_fail_image): Add the routine.
	(int _gfortran_caf_image_status): Same.
	(_gfortran_caf_failed_images): Same.
	(_gfortran_caf_stopped_images): Same.


gcc/testsuite/ChangeLog:

2017-03-05  Andre Vehreschild  <vehre@gcc.gnu.org>
            Alessandro Fanfarillo  <fanfarillo.gcc@gmail.com>

	* gfortran.dg/coarray/fail_image_1.f08: New test.
	* gfortran.dg/coarray/fail_image_2.f08: New test.
	* gfortran.dg/coarray/failed_images_1.f08: New test.
	* gfortran.dg/coarray/failed_images_2.f08: New test.
	* gfortran.dg/coarray/image_status_1.f08: New test.
	* gfortran.dg/coarray/image_status_2.f08: New test.
	* gfortran.dg/coarray/stopped_images_1.f08: New test.
	* gfortran.dg/coarray/stopped_images_2.f08: New test.
	* gfortran.dg/coarray_fail_st.f90: New test.
	* gfortran.dg/coarray_failed_images_1.f08: New test.
	* gfortran.dg/coarray_image_status_1.f08: New test.
	* gfortran.dg/coarray_stopped_images_1.f08: New test.

From-SVN: r245900
This commit is contained in:
Andre Vehreschild 2017-03-05 12:35:47 +01:00
parent 55a8bcbb1f
commit ef78bc3c0b
38 changed files with 871 additions and 19 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

48
gcc/fortran/ChangeLog
View file

@ -1,3 +1,51 @@
2017-03-05 Andre Vehreschild <vehre@gcc.gnu.org>,
Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>
* check.c (positive_check): Add new function checking constant for
being greater then zero.
(gfc_check_image_status): Add checking of image_status arguments.
(gfc_check_failed_or_stopped_images): Same but for failed_- and
stopped_images function.
* dump-parse-tree.c (show_code_node): Added output of FAIL IMAGE.
* gfortran.h (enum gfc_statement): Added FAIL_IMAGE_ST.
(enum gfc_isym_id): Added new intrinsic symbols.
(enum gfc_exec_op): Added EXEC_FAIL_IMAGE.
* gfortran.texi: Added description for the new API functions. Updated
coverage of gfortran of TS18508.
* intrinsic.c (add_functions): Added symbols to resolve new intrinsic
functions.
* intrinsic.h: Added prototypes.
* iresolve.c (gfc_resolve_failed_images): Resolve the failed_images
intrinsic.
(gfc_resolve_image_status): Same for image_status.
(gfc_resolve_stopped_images): Same for stopped_images.
* libgfortran.h: Added prototypes.
* match.c (gfc_match_if): Added matching of FAIL IMAGE statement.
(gfc_match_fail_image): Match a FAIL IMAGE statement.
* match.h: Added prototype.
* parse.c (decode_statement): Added matching for FAIL IMAGE.
(next_statement): Same.
(gfc_ascii_statement): Same.
* resolve.c: Same.
* simplify.c (gfc_simplify_failed_or_stopped_images): For COARRAY=
single a constant result can be returne.d
(gfc_simplify_image_status): For COARRAY=single the result is constant.
* st.c (gfc_free_statement): Added FAIL_IMAGE handling.
* trans-decl.c (gfc_build_builtin_function_decls): Added decls of the
new intrinsics.
* trans-expr.c (gfc_conv_procedure_call): This is first time all
arguments of a function are optional, which is now handled here
correctly.
* trans-intrinsic.c (conv_intrinsic_image_status): Translate
image_status.
(gfc_conv_intrinsic_function): Add support for image_status.
(gfc_is_intrinsic_libcall): Add support for the remaining new
intrinsics.
* trans-stmt.c (gfc_trans_fail_image): Trans a fail image.
* trans-stmt.h: Add the prototype for the above.
* trans.c (trans_code): Dispatch for fail_image.
* trans.h: Add the trees for the new intrinsics.
2017-03-03 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/79841

77
gcc/fortran/check.c
View file

@ -295,6 +295,29 @@ nonnegative_check (const char *arg, gfc_expr *expr)
}
/* If expr is a constant, then check to ensure that it is greater than zero. */
static bool
positive_check (int n, gfc_expr *expr)
{
int i;
if (expr->expr_type == EXPR_CONSTANT)
{
gfc_extract_int (expr, &i);
if (i <= 0)
{
gfc_error ("%qs argument of %qs intrinsic at %L must be positive",
gfc_current_intrinsic_arg[n]->name, gfc_current_intrinsic,
&expr->where);
return false;
}
}
return true;
}
/* If expr2 is constant, then check that the value is less than
(less than or equal to, if 'or_equal' is true) bit_size(expr1). */
@ -1137,6 +1160,60 @@ gfc_check_atomic_ref (gfc_expr *value, gfc_expr *atom, gfc_expr *stat)
}
bool
gfc_check_image_status (gfc_expr *image, gfc_expr *team)
{
/* IMAGE has to be a positive, scalar integer. */
if (!type_check (image, 0, BT_INTEGER) || !scalar_check (image, 0)
|| !positive_check (0, image))
return false;
if (team)
{
gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
gfc_current_intrinsic_arg[1]->name, gfc_current_intrinsic,
&team->where);
return false;
}
return true;
}
bool
gfc_check_failed_or_stopped_images (gfc_expr *team, gfc_expr *kind)
{
if (team)
{
gfc_error ("%qs argument of %qs intrinsic at %L not yet supported",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&team->where);
return false;
}
if (kind)
{
int k;
if (!type_check (kind, 1, BT_INTEGER) || !scalar_check (kind, 1)
|| !positive_check (1, kind))
return false;
/* Get the kind, reporting error on non-constant or overflow. */
gfc_current_locus = kind->where;
if (gfc_extract_int (kind, &k, 1))
return false;
if (gfc_validate_kind (BT_INTEGER, k, true) == -1)
{
gfc_error ("%qs argument of %qs intrinsic at %L shall specify a "
"valid integer kind", gfc_current_intrinsic_arg[1]->name,
gfc_current_intrinsic, &kind->where);
return false;
}
}
return true;
}
bool
gfc_check_atomic_cas (gfc_expr *atom, gfc_expr *old, gfc_expr *compare,
gfc_expr *new_val, gfc_expr *stat)

4
gcc/fortran/dump-parse-tree.c
View file

@ -1818,6 +1818,10 @@ show_code_node (int level, gfc_code *c)
break;
case EXEC_FAIL_IMAGE:
fputs ("FAIL IMAGE ", dumpfile);
break;
case EXEC_SYNC_ALL:
fputs ("SYNC ALL ", dumpfile);
if (c->expr2 != NULL)

7
gcc/fortran/gfortran.h
View file

@ -263,7 +263,7 @@ enum gfc_statement
ST_OMP_TASKLOOP_SIMD, ST_OMP_END_TASKLOOP_SIMD, ST_OMP_ORDERED_DEPEND,
ST_PROCEDURE, ST_GENERIC, ST_CRITICAL, ST_END_CRITICAL,
ST_GET_FCN_CHARACTERISTICS, ST_LOCK, ST_UNLOCK, ST_EVENT_POST,
ST_EVENT_WAIT,ST_NONE
ST_EVENT_WAIT,ST_FAIL_IMAGE,ST_NONE
};
/* Types of interfaces that we can have. Assignment interfaces are
@ -429,6 +429,7 @@ enum gfc_isym_id
GFC_ISYM_EXP,
GFC_ISYM_EXPONENT,
GFC_ISYM_EXTENDS_TYPE_OF,
GFC_ISYM_FAILED_IMAGES,
GFC_ISYM_FDATE,
GFC_ISYM_FE_RUNTIME_ERROR,
GFC_ISYM_FGET,
@ -472,6 +473,7 @@ enum gfc_isym_id
GFC_ISYM_IEOR,
GFC_ISYM_IERRNO,
GFC_ISYM_IMAGE_INDEX,
GFC_ISYM_IMAGE_STATUS,
GFC_ISYM_INDEX,
GFC_ISYM_INT,
GFC_ISYM_INT2,
@ -585,6 +587,7 @@ enum gfc_isym_id
GFC_ISYM_SRAND,
GFC_ISYM_SR_KIND,
GFC_ISYM_STAT,
GFC_ISYM_STOPPED_IMAGES,
GFC_ISYM_STORAGE_SIZE,
GFC_ISYM_STRIDE,
GFC_ISYM_SUM,
@ -2457,7 +2460,7 @@ enum gfc_exec_op
EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT,
EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END,
EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH,
EXEC_LOCK, EXEC_UNLOCK, EXEC_EVENT_POST, EXEC_EVENT_WAIT,
EXEC_LOCK, EXEC_UNLOCK, EXEC_EVENT_POST, EXEC_EVENT_WAIT, EXEC_FAIL_IMAGE,
EXEC_OACC_KERNELS_LOOP, EXEC_OACC_PARALLEL_LOOP, EXEC_OACC_ROUTINE,
EXEC_OACC_PARALLEL, EXEC_OACC_KERNELS, EXEC_OACC_DATA, EXEC_OACC_HOST_DATA,
EXEC_OACC_LOOP, EXEC_OACC_UPDATE, EXEC_OACC_WAIT, EXEC_OACC_CACHE,

118
gcc/fortran/gfortran.texi
View file

@ -1125,7 +1125,7 @@ of @code{BIND(C) procedures.}
@item GNU Fortran's implementation for variables with @code{ASYNCHRONOUS}
attribute is compatible with TS 29113.
@item Assumed types (@code{TYPE(*)}.
@item Assumed types (@code{TYPE(*)}).
@item Assumed-rank (@code{DIMENSION(..)}). However, the array descriptor
of the TS is not yet supported.
@ -1147,6 +1147,10 @@ do not support polymorphic types or types with allocatable, pointer or
polymorphic components.
@item Events (@code{EVENT POST}, @code{EVENT WAIT}, @code{EVENT_QUERY})
@item Failed images (@code{FAIL IMAGE}, @code{IMAGE_STATUS},
@code{FAILED_IMAGES}, @code{STOPPED_IMAGES})
@end itemize
@ -3873,6 +3877,7 @@ of such a type
* caf_register_t::
* caf_deregister_t::
* caf_reference_t::
* caf_team_t::
@end menu
@node caf_token_t
@ -4035,6 +4040,11 @@ type conversion still needs to take place the type is transported here.
At the moment @code{CAF_ARR_REF_VECTOR} is not implemented in the front end for
descriptor-less arrays. The library caf_single has untested support for it.
@node caf_team_t
@subsection @code{caf_team_t}
Opaque pointer to represent a team-handle. This type is a stand-in for the
future implementation of teams. It is about to change without further notice.
@node Function ABI Documentation
@section Function ABI Documentation
@ -4044,6 +4054,9 @@ descriptor-less arrays. The library caf_single has untested support for it.
* _gfortran_caf_finish:: Finalization function
* _gfortran_caf_this_image:: Querying the image number
* _gfortran_caf_num_images:: Querying the maximal number of images
* _gfortran_caf_image_status :: Query the status of an image
* _gfortran_caf_failed_images :: Get an array of the indexes of the failed images
* _gfortran_caf_stopped_images :: Get an array of the indexes of the stopped images
* _gfortran_caf_register:: Registering coarrays
* _gfortran_caf_deregister:: Deregistering coarrays
* _gfortran_caf_is_present:: Query whether an allocatable or pointer component in a derived type coarray is allocated
@ -4063,6 +4076,7 @@ descriptor-less arrays. The library caf_single has untested support for it.
* _gfortran_caf_sync_memory:: Wait for completion of segment-memory operations
* _gfortran_caf_error_stop:: Error termination with exit code
* _gfortran_caf_error_stop_str:: Error termination with string
* _gfortran_caf_fail_image :: Mark the image failed and end its execution
* _gfortran_caf_atomic_define:: Atomic variable assignment
* _gfortran_caf_atomic_ref:: Atomic variable reference
* _gfortran_caf_atomic_cas:: Atomic compare and swap
@ -4182,6 +4196,90 @@ then the compiler passes @code{distance=0} and @code{failed=-1} to the function.
@end table
@node _gfortran_caf_image_status
@subsection @code{_gfortran_caf_image_status} --- Query the status of an image
@cindex Coarray, _gfortran_caf_image_status
@table @asis
@item @emph{Description}:
Get the status of the image given by the id @var{image} of the team given by
@var{team}. Valid results are zero, for image is ok, @code{STAT_STOPPED_IMAGE}
from the ISO_FORTRAN_ENV module to indicate that the image has been stopped and
@code{STAT_FAILED_IMAGE} also from ISO_FORTRAN_ENV to indicate that the image
has executed a @code{FAIL IMAGE} statement.
@item @emph{Syntax}:
@code{int _gfortran_caf_image_status (int image, caf_team_t * team)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{image} @tab the positive scalar id of the image in the current TEAM.
@item @var{team} @tab optional; team on the which the inquiry is to be
performed.
@end multitable
@item @emph{NOTES}
This function follows TS18508. Because team-functionality is not yet
implemented a null-pointer is passed for the @var{team} argument at the moment.
@end table
@node _gfortran_caf_failed_images
@subsection @code{_gfortran_caf_failed_images} --- Get an array of the indexes of the failed images
@cindex Coarray, _gfortran_caf_failed_images
@table @asis
@item @emph{Description}:
Get an array of image indexes in the current @var{team} that have failed. The
array is sorted ascendingly. When @var{team} is not provided the current team
is to be used. When @var{kind} is provided then the resulting array is of that
integer kind else it is of default integer kind. The returns an unallocated
size zero array when no images have failed.
@item @emph{Syntax}:
@code{int _gfortran_caf_failed_images (caf_team_t * team, int * kind)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{team} @tab optional; team on the which the inquiry is to be
performed.
@item @var{image} @tab optional; the kind of the resulting integer array.
@end multitable
@item @emph{NOTES}
This function follows TS18508. Because team-functionality is not yet
implemented a null-pointer is passed for the @var{team} argument at the moment.
@end table
@node _gfortran_caf_stopped_images
@subsection @code{_gfortran_caf_stopped_images} --- Get an array of the indexes of the stopped images
@cindex Coarray, _gfortran_caf_stopped_images
@table @asis
@item @emph{Description}:
Get an array of image indexes in the current @var{team} that have stopped. The
array is sorted ascendingly. When @var{team} is not provided the current team
is to be used. When @var{kind} is provided then the resulting array is of that
integer kind else it is of default integer kind. The returns an unallocated
size zero array when no images have failed.
@item @emph{Syntax}:
@code{int _gfortran_caf_stopped_images (caf_team_t * team, int * kind)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{team} @tab optional; team on the which the inquiry is to be
performed.
@item @var{image} @tab optional; the kind of the resulting integer array.
@end multitable
@item @emph{NOTES}
This function follows TS18508. Because team-functionality is not yet
implemented a null-pointer is passed for the @var{team} argument at the moment.
@end table
@node _gfortran_caf_register
@subsection @code{_gfortran_caf_register} --- Registering coarrays
@cindex Coarray, _gfortran_caf_register
@ -4993,6 +5091,24 @@ function should terminate the program with a nonzero-exit code.
@node _gfortran_caf_fail_image
@subsection @code{_gfortran_caf_fail_image} --- Mark the image failed and end its execution
@cindex Coarray, _gfortran_caf_fail_image
@table @asis
@item @emph{Description}:
Invoked for an @code{FAIL IMAGE} statement. The function should terminate the
current image.
@item @emph{Syntax}:
@code{void _gfortran_caf_fail_image ()}
@item @emph{NOTES}
This function follows TS18508.
@end table
@node _gfortran_caf_atomic_define
@subsection @code{_gfortran_caf_atomic_define} --- Atomic variable assignment
@cindex Coarray, _gfortran_caf_atomic_define

19
gcc/fortran/intrinsic.c
View file

@ -1840,6 +1840,13 @@ add_functions (void)
a, BT_UNKNOWN, 0, REQUIRED,
mo, BT_UNKNOWN, 0, REQUIRED);
add_sym_2 ("failed_images", GFC_ISYM_FAILED_IMAGES, CLASS_TRANSFORMATIONAL,
ACTUAL_NO, BT_INTEGER, dd, GFC_STD_F2008_TS,
gfc_check_failed_or_stopped_images,
gfc_simplify_failed_or_stopped_images,
gfc_resolve_failed_images, "team", BT_VOID, di, OPTIONAL,
"kind", BT_INTEGER, di, OPTIONAL);
add_sym_0 ("fdate", GFC_ISYM_FDATE, CLASS_IMPURE, ACTUAL_NO, BT_CHARACTER,
dc, GFC_STD_GNU, NULL, NULL, gfc_resolve_fdate);
@ -2081,6 +2088,11 @@ add_functions (void)
gfc_check_image_index, gfc_simplify_image_index, gfc_resolve_image_index,
ca, BT_REAL, dr, REQUIRED, sub, BT_INTEGER, ii, REQUIRED);
add_sym_2 ("image_status", GFC_ISYM_IMAGE_STATUS, CLASS_ELEMENTAL, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F2008_TS, gfc_check_image_status,
gfc_simplify_image_status, gfc_resolve_image_status, "image",
BT_INTEGER, di, REQUIRED, "team", BT_VOID, di, OPTIONAL);
/* The resolution function for INDEX is called gfc_resolve_index_func
because the name gfc_resolve_index is already used in resolve.c. */
add_sym_4 ("index", GFC_ISYM_INDEX, CLASS_ELEMENTAL, ACTUAL_YES,
@ -2989,6 +3001,13 @@ add_functions (void)
make_generic ("stat", GFC_ISYM_STAT, GFC_STD_GNU);
add_sym_2 ("stopped_images", GFC_ISYM_STOPPED_IMAGES, CLASS_TRANSFORMATIONAL,
ACTUAL_NO, BT_INTEGER, dd, GFC_STD_F2008_TS,
gfc_check_failed_or_stopped_images,
gfc_simplify_failed_or_stopped_images,
gfc_resolve_stopped_images, "team", BT_VOID, di, OPTIONAL,
"kind", BT_INTEGER, di, OPTIONAL);
add_sym_2 ("storage_size", GFC_ISYM_STORAGE_SIZE, CLASS_INQUIRY, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F2008,
gfc_check_storage_size, gfc_simplify_storage_size,

9
gcc/fortran/intrinsic.h
View file

@ -71,6 +71,7 @@ bool gfc_check_dshift (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_dtime_etime (gfc_expr *);
bool gfc_check_event_query (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_failed_or_stopped_images (gfc_expr *, gfc_expr *);
bool gfc_check_fgetputc (gfc_expr *, gfc_expr *);
bool gfc_check_fgetput (gfc_expr *);
bool gfc_check_float (gfc_expr *);
@ -92,6 +93,7 @@ bool gfc_check_ibits (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_ichar_iachar (gfc_expr *, gfc_expr *);
bool gfc_check_idnint (gfc_expr *);
bool gfc_check_ieor (gfc_expr *, gfc_expr *);
bool gfc_check_image_status (gfc_expr *, gfc_expr *);
bool gfc_check_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_int (gfc_expr *, gfc_expr *);
bool gfc_check_intconv (gfc_expr *);
@ -292,6 +294,7 @@ gfc_expr *gfc_simplify_erfc_scaled (gfc_expr *);
gfc_expr *gfc_simplify_exp (gfc_expr *);
gfc_expr *gfc_simplify_exponent (gfc_expr *);
gfc_expr *gfc_simplify_extends_type_of (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_failed_or_stopped_images (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_float (gfc_expr *);
gfc_expr *gfc_simplify_floor (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_fraction (gfc_expr *);
@ -308,6 +311,7 @@ gfc_expr *gfc_simplify_ibset (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_ichar (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_ieor (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_image_index (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_image_status (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_int (gfc_expr *, gfc_expr *);
gfc_expr *gfc_simplify_int2 (gfc_expr *);
@ -473,6 +477,7 @@ void gfc_resolve_event_query (gfc_code *);
void gfc_resolve_exp (gfc_expr *, gfc_expr *);
void gfc_resolve_exponent (gfc_expr *, gfc_expr *);
void gfc_resolve_extends_type_of (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_failed_images (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_fdate (gfc_expr *);
void gfc_resolve_floor (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_fnum (gfc_expr *, gfc_expr *);
@ -496,6 +501,7 @@ void gfc_resolve_ibclr (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_ibits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_ibset (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_image_index (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_image_status (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_index_func (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *);
void gfc_resolve_ierrno (gfc_expr *);
@ -571,12 +577,13 @@ void gfc_resolve_signal (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_sin (gfc_expr *, gfc_expr *);
void gfc_resolve_sinh (gfc_expr *, gfc_expr *);
void gfc_resolve_size (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_stride (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_spacing (gfc_expr *, gfc_expr *);
void gfc_resolve_spread (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_sqrt (gfc_expr *, gfc_expr *);
void gfc_resolve_stat (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_stopped_images (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_storage_size (gfc_expr *f, gfc_expr *a, gfc_expr *kind);
void gfc_resolve_stride (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_srand (gfc_code *);
void gfc_resolve_sum (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_symlnk (gfc_expr *, gfc_expr *, gfc_expr *);

49
gcc/fortran/iresolve.c
View file

@ -2830,6 +2830,38 @@ gfc_resolve_atan2d (gfc_expr *f, gfc_expr *x, gfc_expr *y ATTRIBUTE_UNUSED)
}
/* Resolve failed_images (team, kind). */
void
gfc_resolve_failed_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED,
gfc_expr *kind)
{
static char failed_images[] = "_gfortran_caf_failed_images";
f->rank = 1;
f->ts.type = BT_INTEGER;
if (kind == NULL)
f->ts.kind = gfc_default_integer_kind;
else
gfc_extract_int (kind, &f->ts.kind);
f->value.function.name = failed_images;
}
/* Resolve image_status (image, team). */
void
gfc_resolve_image_status (gfc_expr *f, gfc_expr *image ATTRIBUTE_UNUSED,
gfc_expr *team ATTRIBUTE_UNUSED)
{
static char image_status[] = "_gfortran_caf_image_status";
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
f->value.function.name = image_status;
}
/* Resolve image_index (...). */
void
gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
gfc_expr *sub ATTRIBUTE_UNUSED)
@ -2841,6 +2873,23 @@ gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
}
/* Resolve stopped_images (team, kind). */
void
gfc_resolve_stopped_images (gfc_expr *f, gfc_expr *team ATTRIBUTE_UNUSED,
gfc_expr *kind)
{
static char stopped_images[] = "_gfortran_caf_stopped_images";
f->rank = 1;
f->ts.type = BT_INTEGER;
if (kind == NULL)
f->ts.kind = gfc_default_integer_kind;
else
gfc_extract_int (kind, &f->ts.kind);
f->value.function.name = stopped_images;
}
void
gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
gfc_expr *distance ATTRIBUTE_UNUSED)

4
gcc/fortran/libgfortran.h
View file

@ -117,14 +117,14 @@ typedef enum
}
libgfortran_error_codes;
/* Must kept in sync with libgfortrancaf.h. */
/* Must kept in sync with libgfortran/caf/libcaf.h. */
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_FAILED_IMAGE
GFC_STAT_FAILED_IMAGE = 6001
}
libgfortran_stat_codes;

23
gcc/fortran/match.c
View file

@ -1601,6 +1601,7 @@ gfc_match_if (gfc_statement *if_type)
match ("event post", gfc_match_event_post, ST_EVENT_POST)
match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT)
match ("exit", gfc_match_exit, ST_EXIT)
match ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE)
match ("flush", gfc_match_flush, ST_FLUSH)
match ("forall", match_simple_forall, ST_FORALL)
match ("go to", gfc_match_goto, ST_GOTO)
@ -3265,6 +3266,28 @@ gfc_match_event_wait (void)
}
/* Match a FAIL IMAGE statement. */
match
gfc_match_fail_image (void)
{
if (!gfc_notify_std (GFC_STD_F2008_TS, "FAIL IMAGE statement at %C"))
return MATCH_ERROR;
if (gfc_match_char ('(') == MATCH_YES)
goto syntax;
new_st.op = EXEC_FAIL_IMAGE;
return MATCH_YES;
syntax:
gfc_syntax_error (ST_FAIL_IMAGE);
return MATCH_ERROR;
}
/* Match LOCK/UNLOCK statement. Syntax:
LOCK ( lock-variable [ , lock-stat-list ] )
UNLOCK ( lock-variable [ , sync-stat-list ] )

1
gcc/fortran/match.h
View file

@ -73,6 +73,7 @@ match gfc_match_elseif (void);
match gfc_match_event_post (void);
match gfc_match_event_wait (void);
match gfc_match_critical (void);
match gfc_match_fail_image (void);
match gfc_match_block (void);
match gfc_match_associate (void);
match gfc_match_do (void);

6
gcc/fortran/parse.c
View file

@ -488,6 +488,7 @@ decode_statement (void)
break;
case 'f':
match ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE);
match ("final", gfc_match_final_decl, ST_FINAL);
match ("flush", gfc_match_flush, ST_FLUSH);
match ("format", gfc_match_format, ST_FORMAT);
@ -1499,7 +1500,7 @@ next_statement (void)
case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: \
case ST_ERROR_STOP: case ST_SYNC_ALL: \
case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
case ST_EVENT_POST: case ST_EVENT_WAIT: \
case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \
case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
@ -1827,6 +1828,9 @@ gfc_ascii_statement (gfc_statement st)
case ST_EVENT_WAIT:
p = "EVENT WAIT";
break;
case ST_FAIL_IMAGE:
p = "FAIL IMAGE";
break;
case ST_END_ASSOCIATE:
p = "END ASSOCIATE";
break;

3
gcc/fortran/resolve.c
View file

@ -10883,6 +10883,9 @@ start:
resolve_lock_unlock_event (code);
break;
case EXEC_FAIL_IMAGE:
break;
case EXEC_ENTRY:
/* Keep track of which entry we are up to. */
current_entry_id = code->ext.entry->id;

61
gcc/fortran/simplify.c
View file

@ -2465,6 +2465,37 @@ gfc_simplify_exponent (gfc_expr *x)
}
gfc_expr *
gfc_simplify_failed_or_stopped_images (gfc_expr *team ATTRIBUTE_UNUSED,
gfc_expr *kind)
{
if (flag_coarray == GFC_FCOARRAY_NONE)
{
gfc_current_locus = *gfc_current_intrinsic_where;
gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
return &gfc_bad_expr;
}
if (flag_coarray == GFC_FCOARRAY_SINGLE)
{
gfc_expr *result;
int actual_kind;
if (kind)
gfc_extract_int (kind, &actual_kind);
else
actual_kind = gfc_default_integer_kind;
result = gfc_get_array_expr (BT_INTEGER, actual_kind, &gfc_current_locus);
result->rank = 1;
return result;
}
/* For fcoarray = lib no simplification is possible, because it is not known
what images failed or are stopped at compile time. */
return NULL;
}
gfc_expr *
gfc_simplify_float (gfc_expr *a)
{
@ -6763,6 +6794,36 @@ gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
return result;
}
gfc_expr *
gfc_simplify_image_status (gfc_expr *image, gfc_expr *team ATTRIBUTE_UNUSED)
{
if (flag_coarray == GFC_FCOARRAY_NONE)
{
gfc_current_locus = *gfc_current_intrinsic_where;
gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
return &gfc_bad_expr;
}
/* Simplification is possible for fcoarray = single only. For all other modes
the result depends on runtime conditions. */
if (flag_coarray != GFC_FCOARRAY_SINGLE)
return NULL;
if (gfc_is_constant_expr (image))
{
gfc_expr *result;
result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
&image->where);
if (mpz_get_si (image->value.integer) == 1)
mpz_set_si (result->value.integer, 0);
else
mpz_set_si (result->value.integer, GFC_STAT_STOPPED_IMAGE);
return result;
}
else
return NULL;
}
gfc_expr *
gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim,

1
gcc/fortran/st.c
View file

@ -120,6 +120,7 @@ gfc_free_statement (gfc_code *p)
case EXEC_UNLOCK:
case EXEC_EVENT_POST:
case EXEC_EVENT_WAIT:
case EXEC_FAIL_IMAGE:
break;
case EXEC_BLOCK:

26
gcc/fortran/trans-decl.c
View file

@ -153,6 +153,10 @@ tree gfor_fndecl_caf_unlock;
tree gfor_fndecl_caf_event_post;
tree gfor_fndecl_caf_event_wait;
tree gfor_fndecl_caf_event_query;
tree gfor_fndecl_caf_fail_image;
tree gfor_fndecl_caf_failed_images;
tree gfor_fndecl_caf_image_status;
tree gfor_fndecl_caf_stopped_images;
tree gfor_fndecl_co_broadcast;
tree gfor_fndecl_co_max;
tree gfor_fndecl_co_min;
@ -3732,6 +3736,28 @@ gfc_build_builtin_function_decls (void)
void_type_node, 5, pvoid_type_node, size_type_node, integer_type_node,
pint_type, pint_type);
gfor_fndecl_caf_fail_image = gfc_build_library_function_decl (
get_identifier (PREFIX("caf_fail_image")), void_type_node, 0);
/* CAF's FAIL doesn't return. */
TREE_THIS_VOLATILE (gfor_fndecl_caf_fail_image) = 1;
gfor_fndecl_caf_failed_images
= gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_failed_images")), "WRR",
void_type_node, 3, pvoid_type_node, ppvoid_type_node,
integer_type_node);
gfor_fndecl_caf_image_status
= gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_image_status")), "RR",
integer_type_node, 2, integer_type_node, ppvoid_type_node);
gfor_fndecl_caf_stopped_images
= gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_stopped_images")), "WRR",
void_type_node, 3, pvoid_type_node, ppvoid_type_node,
integer_type_node);
gfor_fndecl_co_broadcast = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_co_broadcast")), "W.WW",
void_type_node, 5, pvoid_type_node, integer_type_node,

12
gcc/fortran/trans-expr.c
View file

@ -6228,13 +6228,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_add_block_to_block (&se->pre, &post);
/* Transformational functions of derived types with allocatable
components must have the result allocatable components copied. */
components must have the result allocatable components copied when the
argument is actually given. */
arg = expr->value.function.actual;
if (result && arg && expr->rank
&& expr->value.function.isym
&& expr->value.function.isym->transformational
&& arg->expr->ts.type == BT_DERIVED
&& arg->expr->ts.u.derived->attr.alloc_comp)
&& expr->value.function.isym
&& expr->value.function.isym->transformational
&& arg->expr
&& arg->expr->ts.type == BT_DERIVED
&& arg->expr->ts.u.derived->attr.alloc_comp)
{
tree tmp2;
/* Copy the allocatable components. We have to use a

44
gcc/fortran/trans-intrinsic.c
View file

@ -2388,6 +2388,42 @@ trans_this_image (gfc_se * se, gfc_expr *expr)
}
/* Convert a call to image_status. */
static void
conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr)
{
unsigned int num_args;
tree *args, tmp;
num_args = gfc_intrinsic_argument_list_length (expr);
args = XALLOCAVEC (tree, num_args);
gfc_conv_intrinsic_function_args (se, expr, args, num_args);
/* In args[0] the number of the image the status is desired for has to be
given. */
if (flag_coarray == GFC_FCOARRAY_SINGLE)
{
tree arg;
arg = gfc_evaluate_now (args[0], &se->pre);
tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
fold_convert (integer_type_node, arg),
integer_one_node);
tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
tmp, integer_zero_node,
build_int_cst (integer_type_node,
GFC_STAT_STOPPED_IMAGE));
}
else if (flag_coarray == GFC_FCOARRAY_LIB)
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2,
args[0], build_int_cst (integer_type_node, -1));
else
gcc_unreachable ();
se->expr = tmp;
}
static void
trans_image_index (gfc_se * se, gfc_expr *expr)
{
@ -9108,6 +9144,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
trans_image_index (se, expr);
break;
case GFC_ISYM_IMAGE_STATUS:
conv_intrinsic_image_status (se, expr);
break;
case GFC_ISYM_NUM_IMAGES:
trans_num_images (se, expr);
break;
@ -9458,10 +9498,12 @@ gfc_is_intrinsic_libcall (gfc_expr * expr)
/* Ignore absent optional parameters. */
return 1;
case GFC_ISYM_RESHAPE:
case GFC_ISYM_CSHIFT:
case GFC_ISYM_EOSHIFT:
case GFC_ISYM_FAILED_IMAGES:
case GFC_ISYM_STOPPED_IMAGES:
case GFC_ISYM_PACK:
case GFC_ISYM_RESHAPE:
case GFC_ISYM_UNPACK:
/* Pass absent optional parameters. */
return 2;

18
gcc/fortran/trans-stmt.c
View file

@ -674,6 +674,24 @@ gfc_trans_stop (gfc_code *code, bool error_stop)
return gfc_finish_block (&se.pre);
}
/* Translate the FAIL IMAGE statement. */
tree
gfc_trans_fail_image (gfc_code *code ATTRIBUTE_UNUSED)
{
if (flag_coarray == GFC_FCOARRAY_LIB)
return build_call_expr_loc (input_location,
gfor_fndecl_caf_fail_image, 1,
build_int_cst (pchar_type_node, 0));
else
{
const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4);
gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name);
tree tmp = gfc_get_symbol_decl (exsym);
return build_call_expr_loc (input_location, tmp, 1, integer_zero_node);
}
}
tree
gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op)

1
gcc/fortran/trans-stmt.h
View file

@ -56,6 +56,7 @@ tree gfc_trans_select_type (gfc_code *);
tree gfc_trans_sync (gfc_code *, gfc_exec_op);
tree gfc_trans_lock_unlock (gfc_code *, gfc_exec_op);
tree gfc_trans_event_post_wait (gfc_code *, gfc_exec_op);
tree gfc_trans_fail_image (gfc_code *);
tree gfc_trans_forall (gfc_code *);
tree gfc_trans_where (gfc_code *);
tree gfc_trans_allocate (gfc_code *);

4
gcc/fortran/trans.c
View file

@ -1953,6 +1953,10 @@ trans_code (gfc_code * code, tree cond)
res = gfc_trans_event_post_wait (code, code->op);
break;
case EXEC_FAIL_IMAGE:
res = gfc_trans_fail_image (code);
break;
case EXEC_FORALL:
res = gfc_trans_forall (code);
break;

4
gcc/fortran/trans.h
View file

@ -833,6 +833,10 @@ extern GTY(()) tree gfor_fndecl_caf_unlock;
extern GTY(()) tree gfor_fndecl_caf_event_post;
extern GTY(()) tree gfor_fndecl_caf_event_wait;
extern GTY(()) tree gfor_fndecl_caf_event_query;
extern GTY(()) tree gfor_fndecl_caf_fail_image;
extern GTY(()) tree gfor_fndecl_caf_failed_images;
extern GTY(()) tree gfor_fndecl_caf_image_status;
extern GTY(()) tree gfor_fndecl_caf_stopped_images;
extern GTY(()) tree gfor_fndecl_co_broadcast;
extern GTY(()) tree gfor_fndecl_co_max;
extern GTY(()) tree gfor_fndecl_co_min;

16
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,19 @@
2017-03-05 Andre Vehreschild <vehre@gcc.gnu.org>
Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>
* gfortran.dg/coarray/fail_image_1.f08: New test.
* gfortran.dg/coarray/fail_image_2.f08: New test.
* gfortran.dg/coarray/failed_images_1.f08: New test.
* gfortran.dg/coarray/failed_images_2.f08: New test.
* gfortran.dg/coarray/image_status_1.f08: New test.
* gfortran.dg/coarray/image_status_2.f08: New test.
* gfortran.dg/coarray/stopped_images_1.f08: New test.
* gfortran.dg/coarray/stopped_images_2.f08: New test.
* gfortran.dg/coarray_fail_st.f90: New test.
* gfortran.dg/coarray_failed_images_1.f08: New test.
* gfortran.dg/coarray_image_status_1.f08: New test.
* gfortran.dg/coarray_stopped_images_1.f08: New test.
2017-03-03 Marek Polacek <polacek@redhat.com>
PR c/79758

10
gcc/testsuite/gfortran.dg/coarray/fail_image_1.f08 Normal file
View file

@ -0,0 +1,10 @@
! { dg-do compile }
program fail_image_statement_1
implicit none
fail image ! OK
fail image (1) ! { dg-error "Syntax error in FAIL IMAGE statement at \\(1\\)" }
end program fail_image_statement_1

10
gcc/testsuite/gfortran.dg/coarray/fail_image_2.f08 Normal file
View file

@ -0,0 +1,10 @@
! { dg-do run }
program fail_image_statement_2
implicit none
fail image ! OK
error stop "This statement should not be reached."
end program fail_image_statement_2

20
gcc/testsuite/gfortran.dg/coarray/failed_images_1.f08 Normal file
View file

@ -0,0 +1,20 @@
! { dg-do compile }
program test_failed_images_1
implicit none
integer, allocatable :: fi(:)
real :: r
integer :: i
fi = failed_images() ! OK
fi = failed_images(TEAM=1) ! { dg-error "'team' argument of 'failed_images' intrinsic at \\(1\\) not yet supported" }
fi = failed_images(KIND=1) ! OK
fi = failed_images(KIND=4) ! OK
fi = failed_images(KIND=0) ! { dg-error "'kind' argument of 'failed_images' intrinsic at \\\(1\\\) must be positive" }
fi = failed_images(KIND=r) ! { dg-error "'kind' argument of 'failed_images' intrinsic at \\\(1\\\) must be INTEGER" }
fi = failed_images(KIND=i) ! { dg-error "Constant expression required at \\\(1\\\)" }
fi = failed_images(KIND=42) ! { dg-error "'kind' argument of 'failed_images' intrinsic at \\\(1\\\) shall specify a valid integer kind" }
end program test_failed_images_1

17
gcc/testsuite/gfortran.dg/coarray/failed_images_2.f08 Normal file
View file

@ -0,0 +1,17 @@
! { dg-do run }
program test_failed_images_2
implicit none
integer, allocatable :: fi(:)
integer(kind=1), allocatable :: sfi(:)
fi = failed_images()
if (size(fi) > 0) error stop "failed_images result shall be empty array"
sfi = failed_images(KIND=1)
if (size(sfi) > 0) error stop "failed_images result shall be empty array"
sfi = failed_images(KIND=8)
if (size(sfi) > 0) error stop "failed_images result shall be empty array"
end program test_failed_images_2

26
gcc/testsuite/gfortran.dg/coarray/image_status_1.f08 Normal file
View file

@ -0,0 +1,26 @@
! { dg-do compile }
program test_image_status_1
implicit none
integer :: isv
integer(kind=1) :: k1
integer(kind=2) :: k2
integer(kind=4) :: k4
integer(kind=8) :: k8
isv = image_status(1) ! Ok
isv = image_status(-1) ! { dg-error "'image' argument of 'image_status' intrinsic at \\(1\\) must be positive" }
isv = image_status(0) ! { dg-error "'image' argument of 'image_status' intrinsic at \\(1\\) must be positive" }
isv = image_status(.true.) ! { dg-error "'image' argument of 'image_status' intrinsic at \\(1\\) must be INTEGER" }
isv = image_status([1,2,3]) ! { dg-error "'image' argument of 'image_status' intrinsic at \\(1\\) must be a scalar" }
isv = image_status(k1) ! Ok
isv = image_status(k2) ! Ok
isv = image_status(k4) ! Ok
isv = image_status(k8) ! Ok
isv = image_status(1, team=1) ! { dg-error "'team' argument of 'image_status' intrinsic at \\(1\\) not yet supported" }
isv = image_status() ! { dg-error "Missing actual argument 'image' in call to 'image_status' at \\(1\\)" }
isv = image_status(team=1) ! { dg-error "Missing actual argument 'image' in call to 'image_status' at \\(1\\)" }
end program test_image_status_1

12
gcc/testsuite/gfortran.dg/coarray/image_status_2.f08 Normal file
View file

@ -0,0 +1,12 @@
! { dg-do run }
program test_image_status_2
use iso_fortran_env , only : STAT_STOPPED_IMAGE
implicit none
if (image_status(1) /= 0) error stop "Image 1 should report OK."
if (image_status(2) /= STAT_STOPPED_IMAGE) error stop "Image 2 should be stopped."
if (image_status(3) /= STAT_STOPPED_IMAGE) error stop "Image 3 should be stopped."
end program test_image_status_2

20
gcc/testsuite/gfortran.dg/coarray/stopped_images_1.f08 Normal file
View file

@ -0,0 +1,20 @@
! { dg-do compile }
program test_stopped_images_1
implicit none
integer, allocatable :: gi(:)
real :: r
integer :: i
gi = stopped_images() ! OK
gi = stopped_images(TEAM=1) ! { dg-error "'team' argument of 'stopped_images' intrinsic at \\(1\\) not yet supported" }
gi = stopped_images(KIND=1) ! OK
gi = stopped_images(KIND=4) ! OK
gi = stopped_images(KIND=0) ! { dg-error "'kind' argument of 'stopped_images' intrinsic at \\\(1\\\) must be positive" }
gi = stopped_images(KIND=r) ! { dg-error "'kind' argument of 'stopped_images' intrinsic at \\\(1\\\) must be INTEGER" }
gi = stopped_images(KIND=i) ! { dg-error "Constant expression required at \\\(1\\\)" }
gi = stopped_images(KIND=42) ! { dg-error "'kind' argument of 'stopped_images' intrinsic at \\\(1\\\) shall specify a valid integer kind" }
end program test_stopped_images_1

17
gcc/testsuite/gfortran.dg/coarray/stopped_images_2.f08 Normal file
View file

@ -0,0 +1,17 @@
! { dg-do run }
program test_stopped_images_2
implicit none
integer, allocatable :: si(:)
integer(kind=1), allocatable :: ssi(:)
si = stopped_images()
if (size(si) > 0) error stop "stopped_images result shall be empty array"
ssi = stopped_images(KIND=1)
if (size(ssi) > 0) error stop "stopped_images result shall be empty array"
ssi = stopped_images(KIND=8)
if (size(ssi) > 0) error stop "stopped_images result shall be empty array"
end program test_stopped_images_2

21
gcc/testsuite/gfortran.dg/coarray_fail_st.f90 Normal file
View file

@ -0,0 +1,21 @@
! { dg-do compile }
! { dg-options "-fdump-tree-original -fcoarray=lib" }
!
program fail_statement
implicit none
integer :: me,np,stat
me = this_image()
np = num_images()
stat = 0
if(me == 1) fail image
sync all(stat=stat)
if(stat /= 0) write(*,*) 'Image failed during sync'
end program fail_statement
! { dg-final { scan-tree-dump-times "_gfortran_caf_fail_image \\\(0B\\\);" 1 "original" } }

29
gcc/testsuite/gfortran.dg/coarray_failed_images_1.f08 Normal file
View file

@ -0,0 +1,29 @@
! { dg-do run }
! { dg-options "-fdump-tree-original -fcoarray=lib -lcaf_single" }
program test_failed_images_1
implicit none
integer :: me,np,stat
character(len=1) :: c
integer, allocatable :: fi(:)
integer(kind=1), allocatable :: sfi(:)
fi = failed_images()
if (size(fi) > 0) error stop "failed_images result shall be empty array"
if (allocated(fi)) error stop "failed_images result shall not be allocated"
sfi = failed_images(KIND=1)
if (size(sfi) > 0) error stop "failed_images result shall be empty array"
if (allocated(sfi)) error stop "failed_images result shall not be allocated"
sfi = failed_images(KIND=8)
if (size(sfi) > 0) error stop "failed_images result shall be empty array"
! The implicit type conversion in the assignment above allocates an array.
! if (allocated(sfi)) error stop "failed_images result shall not be allocated"
end program test_failed_images_1
! { dg-final { scan-tree-dump-times "_gfortran_caf_failed_images \\\(&D\\\.\[0-9\]+, 0B, 0B\\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_failed_images \\\(&D\\\.\[0-9\]+, 0B, D\\\.\[0-9\]+\\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_failed_images \\\(&D\\\.\[0-9\]+, 0B, D\\\.\[0-9\]+\\\);" 1 "original" } }

16
gcc/testsuite/gfortran.dg/coarray_image_status_1.f08 Normal file
View file

@ -0,0 +1,16 @@
! { dg-do run }
! { dg-options "-fcoarray=lib -lcaf_single -fdump-tree-original" }
program test_image_status_1
use iso_fortran_env , only : STAT_STOPPED_IMAGE
implicit none
if (image_status(1) /= 0) error stop "image_status(1) should not fail"
if (image_status(42) /= STAT_STOPPED_IMAGE) error stop "image_status(42) should report stopped image"
end program test_image_status_1
! { dg-final { scan-tree-dump-times "_gfortran_caf_image_status \\\(1, .+\\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_image_status \\\(42, .+\\\)" 1 "original" } }

29
gcc/testsuite/gfortran.dg/coarray_stopped_images_1.f08 Normal file
View file

@ -0,0 +1,29 @@
! { dg-do run }
! { dg-options "-fdump-tree-original -fcoarray=lib -lcaf_single" }
program test_stopped_images_1
implicit none
integer :: me,np,stat
character(len=1) :: c
integer, allocatable :: si(:)
integer(kind=1), allocatable :: ssi(:)
si = stopped_images()
if (size(si) > 0) error stop "stopped_images result shall be empty array at 1"
if (allocated(si)) error stop "stopped_images result shall not be allocated at 1"
ssi = stopped_images(KIND=1)
if (size(ssi) > 0) error stop "stopped_images result shall be empty array at 2"
if (allocated(ssi)) error stop "stopped_images result shall not be allocated at 2"
ssi = stopped_images(KIND=8)
if (size(ssi) > 0) error stop "stopped_images result shall be empty array at 3"
! The implicit type conversion in the assignment above allocates an array.
! if (allocated(ssi)) error stop "stopped_images result shall not be allocated at 3"
end program test_stopped_images_1
! { dg-final { scan-tree-dump-times "_gfortran_caf_stopped_images \\\(&D\\\.\[0-9\]+, 0B, 0B\\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_stopped_images \\\(&D\\\.\[0-9\]+, 0B, D\\\.\[0-9\]+\\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_stopped_images \\\(&D\\\.\[0-9\]+, 0B, D\\\.\[0-9\]+\\\);" 1 "original" } }

10
libgfortran/ChangeLog
View file

@ -1,3 +1,13 @@
2017-03-05 Andre Vehreschild <vehre@gcc.gnu.org>
Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>
* caf/libcaf.h: Added prototypes and stat codes for failed and stopped
images.
* caf/single.c (void _gfortran_caf_fail_image): Add the routine.
(int _gfortran_caf_image_status): Same.
(_gfortran_caf_failed_images): Same.
(_gfortran_caf_stopped_images): Same.
2017-03-02 Thomas Koenig <tkoenig@gcc.gnu.org>
Jakub Jelinek <jakub@redhat.com>

27
libgfortran/caf/libcaf.h
View file

@ -41,14 +41,20 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
#define likely(x) __builtin_expect(!!(x), 1)
#define unlikely(x) __builtin_expect(!!(x), 0)
#endif
#endif
/* Definitions of the Fortran 2008 standard; need to kept in sync with
ISO_FORTRAN_ENV, cf. libgfortran.h. */
#define STAT_UNLOCKED 0
#define STAT_LOCKED 1
#define STAT_LOCKED_OTHER_IMAGE 2
#define STAT_STOPPED_IMAGE 6000
#endif
ISO_FORTRAN_ENV, cf. gcc/fortran/libgfortran.h. */
typedef enum
{
CAF_STAT_UNLOCKED = 0,
CAF_STAT_LOCKED,
CAF_STAT_LOCKED_OTHER_IMAGE,
CAF_STAT_STOPPED_IMAGE = 6000,
CAF_STAT_FAILED_IMAGE = 6001
}
caf_stat_codes_t;
/* Describes what type of array we are registerring. Keep in sync with
gcc/fortran/trans.h. */
@ -74,6 +80,7 @@ typedef enum caf_deregister_t {
caf_deregister_t;
typedef void* caf_token_t;
typedef void * caf_team_t;
typedef gfc_array_void gfc_descriptor_t;
/* Linked list of static coarrays registered. */
@ -198,6 +205,7 @@ void _gfortran_caf_stop_str (const char *, int32_t)
void _gfortran_caf_error_stop_str (const char *, int32_t)
__attribute__ ((noreturn));
void _gfortran_caf_error_stop (int32_t) __attribute__ ((noreturn));
void _gfortran_caf_fail_image (void) __attribute__ ((noreturn));
void _gfortran_caf_co_broadcast (gfc_descriptor_t *, int, int *, char *, int);
void _gfortran_caf_co_sum (gfc_descriptor_t *, int, int *, char *, int);
@ -243,6 +251,13 @@ void _gfortran_caf_event_post (caf_token_t, size_t, int, int *, char *, int);
void _gfortran_caf_event_wait (caf_token_t, size_t, int, int *, char *, int);
void _gfortran_caf_event_query (caf_token_t, size_t, int, int *, int *);
void _gfortran_caf_failed_images (gfc_descriptor_t *,
caf_team_t * __attribute__ ((unused)), int *);
int _gfortran_caf_image_status (int, caf_team_t * __attribute__ ((unused)));
void _gfortran_caf_stopped_images (gfc_descriptor_t *,
caf_team_t * __attribute__ ((unused)),
int *);
int _gfortran_caf_is_present (caf_token_t, int, caf_reference_t *);
#endif /* LIBCAF_H */

71
libgfortran/caf/single.c
View file

@ -264,6 +264,7 @@ _gfortran_caf_sync_images (int count __attribute__ ((unused)),
*stat = 0;
}
void
_gfortran_caf_stop_numeric(int32_t stop_code)
{
@ -271,6 +272,7 @@ _gfortran_caf_stop_numeric(int32_t stop_code)
exit (0);
}
void
_gfortran_caf_stop_str(const char *string, int32_t len)
{
@ -282,6 +284,7 @@ _gfortran_caf_stop_str(const char *string, int32_t len)
exit (0);
}
void
_gfortran_caf_error_stop_str (const char *string, int32_t len)
{
@ -294,6 +297,74 @@ _gfortran_caf_error_stop_str (const char *string, int32_t len)
}
/* Reported that the program terminated because of a fail image issued.
Because this is a single image library, nothing else than aborting the whole
program can be done. */
void _gfortran_caf_fail_image (void)
{
fputs ("IMAGE FAILED!\n", stderr);
exit (0);
}
/* Get the status of image IMAGE. Because being the single image library all
other images are reported to be stopped. */
int _gfortran_caf_image_status (int image,
caf_team_t * team __attribute__ ((unused)))
{
if (image == 1)
return 0;
else
return CAF_STAT_STOPPED_IMAGE;
}
/* Single image library. There can not be any failed images with only one
image. */
void
_gfortran_caf_failed_images (gfc_descriptor_t *array,
caf_team_t * team __attribute__ ((unused)),
int * kind)
{
int local_kind = kind != NULL ? *kind : 4;
array->base_addr = NULL;
array->dtype = ((BT_INTEGER << GFC_DTYPE_TYPE_SHIFT)
| (local_kind << GFC_DTYPE_SIZE_SHIFT));
/* Setting lower_bound higher then upper_bound is what the compiler does to
indicate an empty array. */
array->dim[0].lower_bound = 0;
array->dim[0]._ubound = -1;
array->dim[0]._stride = 1;
array->offset = 0;
}
/* With only one image available no other images can be stopped. Therefore
return an empty array. */
void
_gfortran_caf_stopped_images (gfc_descriptor_t *array,
caf_team_t * team __attribute__ ((unused)),
int * kind)
{
int local_kind = kind != NULL ? *kind : 4;
array->base_addr = NULL;
array->dtype = ((BT_INTEGER << GFC_DTYPE_TYPE_SHIFT)
| (local_kind << GFC_DTYPE_SIZE_SHIFT));
/* Setting lower_bound higher then upper_bound is what the compiler does to
indicate an empty array. */
array->dim[0].lower_bound = 0;
array->dim[0]._ubound = -1;
array->dim[0]._stride = 1;
array->offset = 0;
}
void
_gfortran_caf_error_stop (int32_t error)
{