OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

check.c (gfc_check_event_query): New function.

Browse Source 
2015-12-02  Tobias Burnus  <burnus@net-b.de>
	    Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>

	* check.c (gfc_check_event_query): New function.
	* dump-parse-tree.c (show_code_node): Handle EXEC_EVENT_POST,
	EXEC_EVENT_WAIT.
	* expr.c (gfc_check_vardef_context): New check for event variables
	definition.
	* gfortran.h (gfc_statement): Add ST_EVENT_POST, ST_EVENT_WAIT.
	(gfc_isym_id): GFC_ISYM_EVENT_QUERY.
	(struct symbol_attribute): New field.
	(gfc_exec_op): Add EXEC_EVENT_POST and EXEC_EVENT_WAIT.
	* gfortran.texi: Document about new events functions and minor
	changes.
	* interface.c (compare_parameter): New check.
	(gfc_procedure_use): New check for explicit procedure interface.
	(add_subroutines): Add event_query.
	* intrinsic.h (gfc_check_event_query,gfc_resolve_event_query):
	New prototypes.
	* iresolve.c (gfc_resolve_event_query): New function.
	* iso-fortran-env.def (event_type): New type.
	* match.c (event_statement,gfc_match_event_post,gfc_match_event_wait):
	New functions.
	(gfc_match_name): New event post and event wait.
	* match.h (gfc_match_event_post,gfc_match_event_wait):
	New prototypes.
	* module.c (ab_attribute): Add AB_EVENT_COMP.
	(attr_bits): Likewise.
	(mio_symbol_attribute): Handle event_comp attribute.
	* parse.c (decode_statement): Add ST_EVENT_POST, ST_EVENT_WAIT.
	(next_statement): Add ST_EVENT_POST, ST_EVENT_WAIT.
	(gfc_ascii_statement): Add ST_EVENT_POST, ST_EVENT_WAIT.
	(parse_derived): Check for event_type components.
	* resolve.c (resolve_allocate_expr): Check for event variable def.
	(resolve_lock_unlock): Renamed to resolve_lock_unlock_event. It
	includes logic for locks and events.
	(gfc_resolve_code): Call it.
	(gfc_resolve_symbol): New check for event variable to be a corray.
	* st.c (gfc_free_statement): Handle new EXEC_EVENT_POST and
	EXEC_EVENT_WAIT.
	* trans-decl.c (gfor_fndecl_caf_event_post,gfor_fndecl_caf_event_wait,
	gfor_fndecl_caf_event_query): New global variables.
	(generate_coarray_sym_init): Checking for event_type.
	(gfc_conv_procedure_call): Check for C bind attribute.
	* trans-intrinsic.c (conv_intrinsic_event_query): New function.
	(conv_intrinsic_move_alloc): Call it.
	* trans-stmt.c (gfc_trans_lock_unlock): Passing address
	of actual argument.
	(gfc_trans_sync): Likewise.
	(gfc_trans_event_post_wait): New function.
	* trans-stmt.h (gfc_trans_event_post_wait): New prototype.
	* trans-types.c (gfc_get_derived_type): Integer_kind as event_type.
	* trans.c (gfc_allocate_using_lib): New argument and logic for events.
	(gfc_allocate_allocatable): Passing new argument.
	(trans_code): Handle EXEC_EVENT_POST, EXEC_EVENT_WAIT.
	* trans.h (gfc_coarray_type): New elements.
	(gfor_fndecl_caf_event_post,gfor_fndecl_caf_event_wait,
	gfor_fndecl_caf_event_query): Declare them.

2015-12-02  Tobias Burnus  <burnus@net-b.de>
	    Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>

	* gfortran.dg/coarray/event_1.f90: New.
	* gfortran.dg/coarray/event_2.f90: New.

Co-Authored-By: Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>

From-SVN: r231208
This commit is contained in:
Tobias Burnus 2015-12-02 22:59:05 +01:00 committed by Steven G. Kargl
parent ca377fc371
commit 5df445a2a5
31 changed files with 1264 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
gcc/fortran/ChangeLog
View File

@ -1,3 +1,62 @@
2015-12-02 Tobias Burnus <burnus@net-b.de>
Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>
* check.c (gfc_check_event_query): New function.
* dump-parse-tree.c (show_code_node): Handle EXEC_EVENT_POST,
EXEC_EVENT_WAIT.
* expr.c (gfc_check_vardef_context): New check for event variables
definition.
* gfortran.h (gfc_statement): Add ST_EVENT_POST, ST_EVENT_WAIT.
(gfc_isym_id): GFC_ISYM_EVENT_QUERY.
(struct symbol_attribute): New field.
(gfc_exec_op): Add EXEC_EVENT_POST and EXEC_EVENT_WAIT.
* gfortran.texi: Document about new events functions and minor
changes.
* interface.c (compare_parameter): New check.
(gfc_procedure_use): New check for explicit procedure interface.
(add_subroutines): Add event_query.
* intrinsic.h (gfc_check_event_query,gfc_resolve_event_query):
New prototypes.
* iresolve.c (gfc_resolve_event_query): New function.
* iso-fortran-env.def (event_type): New type.
* match.c (event_statement,gfc_match_event_post,gfc_match_event_wait):
New functions.
(gfc_match_name): New event post and event wait.
* match.h (gfc_match_event_post,gfc_match_event_wait):
New prototypes.
* module.c (ab_attribute): Add AB_EVENT_COMP.
(attr_bits): Likewise.
(mio_symbol_attribute): Handle event_comp attribute.
* parse.c (decode_statement): Add ST_EVENT_POST, ST_EVENT_WAIT.
(next_statement): Add ST_EVENT_POST, ST_EVENT_WAIT.
(gfc_ascii_statement): Add ST_EVENT_POST, ST_EVENT_WAIT.
(parse_derived): Check for event_type components.
* resolve.c (resolve_allocate_expr): Check for event variable def.
(resolve_lock_unlock): Renamed to resolve_lock_unlock_event. It
includes logic for locks and events.
(gfc_resolve_code): Call it.
(gfc_resolve_symbol): New check for event variable to be a corray.
* st.c (gfc_free_statement): Handle new EXEC_EVENT_POST and
EXEC_EVENT_WAIT.
* trans-decl.c (gfor_fndecl_caf_event_post,gfor_fndecl_caf_event_wait,
gfor_fndecl_caf_event_query): New global variables.
(generate_coarray_sym_init): Checking for event_type.
(gfc_conv_procedure_call): Check for C bind attribute.
* trans-intrinsic.c (conv_intrinsic_event_query): New function.
(conv_intrinsic_move_alloc): Call it.
* trans-stmt.c (gfc_trans_lock_unlock): Passing address
of actual argument.
(gfc_trans_sync): Likewise.
(gfc_trans_event_post_wait): New function.
* trans-stmt.h (gfc_trans_event_post_wait): New prototype.
* trans-types.c (gfc_get_derived_type): Integer_kind as event_type.
* trans.c (gfc_allocate_using_lib): New argument and logic for events.
(gfc_allocate_allocatable): Passing new argument.
(trans_code): Handle EXEC_EVENT_POST, EXEC_EVENT_WAIT.
* trans.h (gfc_coarray_type): New elements.
(gfor_fndecl_caf_event_post,gfor_fndecl_caf_event_wait,
gfor_fndecl_caf_event_query): Declare them.
2015-12-02 Cesar Philippidis <cesar@codesourcery.com>
PR fortran/63861

53
gcc/fortran/check.c
View File

@ -1157,6 +1157,59 @@ gfc_check_atomic_cas (gfc_expr *atom, gfc_expr *old, gfc_expr *compare,
return true;
}
bool
gfc_check_event_query (gfc_expr *event, gfc_expr *count, gfc_expr *stat)
{
if (event->ts.type != BT_DERIVED
|| event->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
|| event->ts.u.derived->intmod_sym_id != ISOFORTRAN_EVENT_TYPE)
{
gfc_error ("EVENT argument at %L to the intrinsic EVENT_QUERY "
"shall be of type EVENT_TYPE", &event->where);
return false;
}
if (!scalar_check (event, 0))
return false;
if (!gfc_check_vardef_context (count, false, false, false, NULL))
{
gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
"shall be definable", &count->where);
return false;
}
if (!type_check (count, 1, BT_INTEGER))
return false;
int i = gfc_validate_kind (BT_INTEGER, count->ts.kind, false);
int j = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false);
if (gfc_integer_kinds[i].range < gfc_integer_kinds[j].range)
{
gfc_error ("COUNT argument of the EVENT_QUERY intrinsic function at %L "
"shall have at least the range of the default integer",
&count->where);
return false;
}
if (stat != NULL)
{
if (!type_check (stat, 2, BT_INTEGER))
return false;
if (!scalar_check (stat, 2))
return false;
if (!variable_check (stat, 2, false))
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_fetch_op (gfc_expr *atom, gfc_expr *value, gfc_expr *old,

27
gcc/fortran/dump-parse-tree.c
View File

@ -1673,6 +1673,33 @@ show_code_node (int level, gfc_code *c)
}
break;
case EXEC_EVENT_POST:
case EXEC_EVENT_WAIT:
if (c->op == EXEC_EVENT_POST)
fputs ("EVENT POST ", dumpfile);
else
fputs ("EVENT WAIT ", dumpfile);
fputs ("event-variable=", dumpfile);
if (c->expr1 != NULL)
show_expr (c->expr1);
if (c->expr4 != NULL)
{
fputs (" until_count=", dumpfile);
show_expr (c->expr4);
}
if (c->expr2 != NULL)
{
fputs (" stat=", dumpfile);
show_expr (c->expr2);
}
if (c->expr3 != NULL)
{
fputs (" errmsg=", dumpfile);
show_expr (c->expr3);
}
break;
case EXEC_LOCK:
case EXEC_UNLOCK:
if (c->op == EXEC_LOCK)

13
gcc/fortran/expr.c
View File

@ -4860,6 +4860,19 @@ gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
return false;
}
/* TS18508, C702/C203. */
if (!alloc_obj
&& (attr.lock_comp
|| (e->ts.type == BT_DERIVED
&& e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
&& e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)))
{
if (context)
gfc_error ("LOCK_EVENT in variable definition context (%s) at %L",
context, &e->where);
return false;
}
/* INTENT(IN) dummy argument. Check this, unless the object itself is the
component of sub-component of a pointer; we need to distinguish
assignment to a pointer component from pointer-assignment to a pointer

8
gcc/fortran/gfortran.h
View File

@ -241,7 +241,8 @@ enum gfc_statement
ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD,
ST_PROCEDURE, ST_GENERIC, ST_CRITICAL, ST_END_CRITICAL,
ST_GET_FCN_CHARACTERISTICS, ST_LOCK, ST_UNLOCK, ST_NONE
ST_GET_FCN_CHARACTERISTICS, ST_LOCK, ST_UNLOCK, ST_EVENT_POST,
ST_EVENT_WAIT,ST_NONE
};
/* Types of interfaces that we can have. Assignment interfaces are
@ -393,6 +394,7 @@ enum gfc_isym_id
GFC_ISYM_ERFC,
GFC_ISYM_ERFC_SCALED,
GFC_ISYM_ETIME,
GFC_ISYM_EVENT_QUERY,
GFC_ISYM_EXECUTE_COMMAND_LINE,
GFC_ISYM_EXIT,
GFC_ISYM_EXP,
@ -828,7 +830,7 @@ typedef struct
entities. */
unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1,
private_comp:1, zero_comp:1, coarray_comp:1, lock_comp:1,
defined_assign_comp:1, unlimited_polymorphic:1;
event_comp:1, defined_assign_comp:1, unlimited_polymorphic:1;
/* This is a temporary selector for SELECT TYPE or an associate
variable for SELECT_TYPE or ASSOCIATE. */
@ -2366,7 +2368,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_LOCK, EXEC_UNLOCK, EXEC_EVENT_POST, EXEC_EVENT_WAIT,
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,

138
gcc/fortran/gfortran.texi
View File

@ -3342,7 +3342,9 @@ typedef enum caf_register_t {
CAF_REGTYPE_COARRAY_ALLOC,
CAF_REGTYPE_LOCK_STATIC,
CAF_REGTYPE_LOCK_ALLOC,
CAF_REGTYPE_CRITICAL
CAF_REGTYPE_CRITICAL,
CAF_REGTYPE_EVENT_STATIC,
CAF_REGTYPE_EVENT_ALLOC
}
caf_register_t;
@end verbatim
@ -3363,6 +3365,9 @@ caf_register_t;
* _gfortran_caf_sendget:: Sending data between remote images
* _gfortran_caf_lock:: Locking a lock variable
* _gfortran_caf_unlock:: Unlocking a lock variable
* _gfortran_caf_event_post:: Post an event
* _gfortran_caf_event_wait:: Wait that an event occurred
* _gfortran_caf_event_query:: Query event count
* _gfortran_caf_sync_all:: All-image barrier
* _gfortran_caf_sync_images:: Barrier for selected images
* _gfortran_caf_sync_memory:: Wait for completion of segment-memory operations
@ -3516,7 +3521,7 @@ int *stat, char *errmsg, int errmsg_len)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{size} @tab For normal coarrays, the byte size of the coarray to be
allocated; for lock types, the number of elements.
allocated; for lock types and event types, the number of elements.
@item @var{type} @tab one of the caf_register_t types.
@item @var{token} @tab intent(out) An opaque pointer identifying the coarray.
@item @var{stat} @tab intent(out) For allocatable coarrays, stores the STAT=;
@ -3541,7 +3546,10 @@ image. For lock types, the value shall only used for checking the allocation
status. Note that for critical blocks, the locking is only required on one
image; in the locking statement, the processor shall always pass always an
image index of one for critical-block lock variables
(@code{CAF_REGTYPE_CRITICAL}).
(@code{CAF_REGTYPE_CRITICAL}). For lock types and critical-block variables,
the initial value shall be unlocked (or, respecitively, not in critical
section) such as the value false; for event types, the initial state should
be no event, e.g. zero.
@end table
@ -3561,8 +3569,7 @@ int errmsg_len)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{stat} @tab intent(out) For allocatable coarrays, stores the STAT=;
may be NULL
@item @var{stat} @tab intent(out) Stores the STAT=; may be NULL
@item @var{errmsg} @tab intent(out) When an error occurs, this will be set
to an error message; may be NULL
@item @var{errmsg_len} @tab the buffer size of errmsg.
@ -3769,8 +3776,7 @@ always 0.
number.
@item @var{aquired_lock} @tab intent(out) If not NULL, it returns whether lock
could be obtained
@item @var{stat} @tab intent(out) For allocatable coarrays, stores the STAT=;
may be NULL
@item @var{stat} @tab intent(out) Stores the STAT=; may be NULL
@item @var{errmsg} @tab intent(out) When an error occurs, this will be set to
an error message; may be NULL
@item @var{errmsg_len} @tab the buffer size of errmsg.
@ -3782,7 +3788,6 @@ is always zero and the image index is one. Libraries are permitted to use other
images for critical-block locking variables.
@end table
@node _gfortran_caf_unlock
@subsection @code{_gfortran_caf_lock} --- Unlocking a lock variable
@cindex Coarray, _gfortran_caf_unlock
@ -3817,6 +3822,115 @@ is always zero and the image index is one. Libraries are permitted to use other
images for critical-block locking variables.
@end table
@node _gfortran_caf_event_post
@subsection @code{_gfortran_caf_event_post} --- Post an event
@cindex Coarray, _gfortran_caf_event_post
@table @asis
@item @emph{Description}:
Increment the event count of the specified event variable.
@item @emph{Syntax}:
@code{void _gfortran_caf_event_post (caf_token_t token, size_t index,
int image_index, int *stat, char *errmsg, int errmsg_len)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{token} @tab intent(in) An opaque pointer identifying the coarray.
@item @var{index} @tab Array index; first array index is 0. For scalars, it is
always 0.
@item @var{image_index} @tab The ID of the remote image; must be a positive
number; zero indicates the current image when accessed noncoindexed.
@item @var{stat} @tab intent(out) Stores the STAT=; may be NULL
@item @var{errmsg} @tab intent(out) When an error occurs, this will be set to
an error message; may be NULL
@item @var{errmsg_len} @tab the buffer size of errmsg.
@end multitable
@item @emph{NOTES}
This acts like an atomic add of one to the remote image's event variable.
The statement is an image-control statement but does not imply sync memory.
Still, all preceeding push communications of this image to the specified
remote image has to be completed before @code{event_wait} on the remote
image returns.
@end table
@node _gfortran_caf_event_wait
@subsection @code{_gfortran_caf_event_wait} --- Wait that an event occurred
@cindex Coarray, _gfortran_caf_event_wait
@table @asis
@item @emph{Description}:
Wait until the event count has reached at least the specified
@var{until_count}; if so, atomically decrement the event variable by this
amount and return.
@item @emph{Syntax}:
@code{void _gfortran_caf_event_wait (caf_token_t token, size_t index,
int until_count, int *stat, char *errmsg, int errmsg_len)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{token} @tab intent(in) An opaque pointer identifying the coarray.
@item @var{index} @tab Array index; first array index is 0. For scalars, it is
always 0.
@item @var{until_count} @tab The number of events which have to be available
before the function returns.
@item @var{stat} @tab intent(out) Stores the STAT=; may be NULL
@item @var{errmsg} @tab intent(out) When an error occurs, this will be set to
an error message; may be NULL
@item @var{errmsg_len} @tab the buffer size of errmsg.
@end multitable
@item @emph{NOTES}
This function only operates on a local coarray. It acts like a loop checking
atomically the value of the event variable, breaking if the value is greater
or equal the requested number of counts. Before the function returns, the
event variable has to be decremented by the requested @var{until_count} value.
A possible implementation would be a busy loop for a certain number of spins
(possibly depending on the number of threads relative to the number of available
cores) followed by other waiting strategy such as a sleeping wait (possibly with
an increasing number of sleep time) or, if possible, a futex wait.
The statement is an image-control statement but does not imply sync memory.
Still, all preceeding push communications to this image of images having
issued a @code{event_push} have to be completed before this function returns.
@end table
@node _gfortran_caf_event_query
@subsection @code{_gfortran_caf_event_query} --- Query event count
@cindex Coarray, _gfortran_caf_event_query
@table @asis
@item @emph{Description}:
Return the event count of the specified event count.
@item @emph{Syntax}:
@code{void _gfortran_caf_event_query (caf_token_t token, size_t index,
int image_index, int *count, int *stat)}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{token} @tab intent(in) An opaque pointer identifying the coarray.
@item @var{index} @tab Array index; first array index is 0. For scalars, it is
always 0.
@item @var{image_index} @tab The ID of the remote image; must be a positive
number; zero indicates the current image when accessed noncoindexed.
@item @var{count} @tab intent(out) The number of events currently posted to
the event variable
@item @var{stat} @tab intent(out) Stores the STAT=; may be NULL
@end multitable
@item @emph{NOTES}
The typical use is to check the local even variable to only call
@code{event_wait} when the data is available. However, a coindexed variable
is permitted; there is no ordering or synchronization implied. It acts like
an atomic fetch of the value of the event variable.
@end table
@node _gfortran_caf_sync_all
@subsection @code{_gfortran_caf_sync_all} --- All-image barrier
@ -3962,7 +4076,7 @@ int image_index, void *value, int *stat, int type, int kind)}
@item @var{offset} @tab By which amount of bytes the actual data is shifted
compared to the base address of the coarray.
@item @var{image_index} @tab The ID of the remote image; must be a positive
number.
number; zero indicates the current image when used noncoindexed.
@item @var{value} @tab intent(in) the value to be assigned, passed by reference.
@item @var{stat} @tab intent(out) Stores the status STAT= and may be NULL.
@item @var{type} @tab the data type, i.e. @code{BT_INTEGER} (1) or
@ -3992,7 +4106,7 @@ int image_index, void *value, int *stat, int type, int kind)}
@item @var{offset} @tab By which amount of bytes the actual data is shifted
compared to the base address of the coarray.
@item @var{image_index} @tab The ID of the remote image; must be a positive
number.
number; zero indicates the current image when used noncoindexed.
@item @var{value} @tab intent(out) The variable assigned the atomically
referenced variable.
@item @var{stat} @tab intent(out) Stores the status STAT= and may be NULL.
@ -4025,7 +4139,7 @@ int type, int kind)}
@item @var{offset} @tab By which amount of bytes the actual data is shifted
compared to the base address of the coarray.
@item @var{image_index} @tab The ID of the remote image; must be a positive
number.
number; zero indicates the current image when used noncoindexed.
@item @var{old} @tab intent(out) the value which the atomic variable had
just before the cas operation.
@item @var{compare} @tab intent(in) The value used for comparision.
@ -4067,7 +4181,7 @@ int image_index, void *value, void *old, int *stat, int type, int kind)}
@item @var{offset} @tab By which amount of bytes the actual data is shifted
compared to the base address of the coarray.
@item @var{image_index} @tab The ID of the remote image; must be a positive
number.
number; zero indicates the current image when used noncoindexed.
@item @var{old} @tab intent(out) the value which the atomic variable had
just before the atomic operation.
@item @var{val} @tab intent(in) The new value for the atomic variable,

28
gcc/fortran/interface.c
View File

@ -2157,6 +2157,21 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
formal->name, &actual->where);
return 0;
}
/* TS18508, C702/C703. */
if (formal->attr.intent != INTENT_INOUT
&& (((formal->ts.type == BT_DERIVED || formal->ts.type == BT_CLASS)
&& formal->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
&& formal->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
|| formal->attr.event_comp))
{
if (where)
gfc_error ("Actual argument to non-INTENT(INOUT) dummy %qs at %L, "
"which is EVENT_TYPE or has a EVENT_TYPE component",
formal->name, &actual->where);
return 0;
}
}
/* F2008, C1239/C1240. */
@ -3385,6 +3400,19 @@ gfc_procedure_use (gfc_symbol *sym, gfc_actual_arglist **ap, locus *where)
break;
}
if (a->expr
&& (a->expr->ts.type == BT_DERIVED || a->expr->ts.type == BT_CLASS)
&& ((a->expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
&& a->expr->ts.u.derived->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE)
|| gfc_expr_attr (a->expr).event_comp))
{
gfc_error ("Actual argument of EVENT_TYPE or with EVENT_TYPE "
"component at %L requires an explicit interface for "
"procedure %qs", &a->expr->where, sym->name);
break;
}
if (a->expr && a->expr->expr_type == EXPR_NULL
&& a->expr->ts.type == BT_UNKNOWN)
{

7
gcc/fortran/intrinsic.c
View File

@ -3164,6 +3164,13 @@ add_subroutines (void)
GFC_STD_F95, gfc_check_cpu_time, NULL, gfc_resolve_cpu_time,
tm, BT_REAL, dr, REQUIRED, INTENT_OUT);
add_sym_3s ("event_query", GFC_ISYM_EVENT_QUERY, CLASS_ATOMIC,
BT_UNKNOWN, 0, GFC_STD_F2008_TS,
gfc_check_event_query, NULL, gfc_resolve_event_query,
"event", BT_INTEGER, di, REQUIRED, INTENT_IN,
c, BT_INTEGER, di, OPTIONAL, INTENT_IN,
stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
/* More G77 compatibility garbage. */
add_sym_2s ("ctime", GFC_ISYM_CTIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_ctime_sub, NULL, gfc_resolve_ctime_sub,

2
gcc/fortran/intrinsic.h
View File

@ -70,6 +70,7 @@ bool gfc_check_dprod (gfc_expr *, gfc_expr *);
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_fgetputc (gfc_expr *, gfc_expr *);
bool gfc_check_fgetput (gfc_expr *);
bool gfc_check_float (gfc_expr *);
@ -462,6 +463,7 @@ void gfc_resolve_dtime_sub (gfc_code *);
void gfc_resolve_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
gfc_expr *);
void gfc_resolve_etime_sub (gfc_code *);
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 *);

6
gcc/fortran/iresolve.c
View File

@ -2945,6 +2945,12 @@ gfc_resolve_atomic_ref (gfc_code *c)
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
gfc_resolve_event_query (gfc_code *c)
{
const char *name = "event_query";
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
void
gfc_resolve_mvbits (gfc_code *c)

5
gcc/fortran/iso-fortran-env.def
View File

@ -123,6 +123,11 @@ NAMED_FUNCTION (ISOFORTRAN_COMPILER_VERSION, "compiler_version", \
NAMED_DERIVED_TYPE (ISOFORTRAN_LOCK_TYPE, "lock_type", \
get_int_kind_from_node (ptr_type_node), GFC_STD_F2008)
NAMED_DERIVED_TYPE (ISOFORTRAN_EVENT_TYPE, "event_type", \
flag_coarray == GFC_FCOARRAY_LIB
? get_int_kind_from_node (ptr_type_node)
: gfc_default_integer_kind, GFC_STD_F2008_TS)
#undef NAMED_INTCST
#undef NAMED_KINDARRAY
#undef NAMED_FUNCTION

198
gcc/fortran/match.c
View File

@ -1463,6 +1463,8 @@ gfc_match_if (gfc_statement *if_type)
match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
match ("end file", gfc_match_endfile, ST_END_FILE)
match ("error stop", gfc_match_error_stop, ST_ERROR_STOP)
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 ("flush", gfc_match_flush, ST_FLUSH)
match ("forall", match_simple_forall, ST_FORALL)
@ -2747,6 +2749,202 @@ gfc_match_error_stop (void)
return gfc_match_stopcode (ST_ERROR_STOP);
}
/* Match EVENT POST/WAIT statement. Syntax:
EVENT POST ( event-variable [, sync-stat-list] )
EVENT WAIT ( event-variable [, wait-spec-list] )
with
wait-spec-list is sync-stat-list or until-spec
until-spec is UNTIL_COUNT = scalar-int-expr
sync-stat is STAT= or ERRMSG=. */
static match
event_statement (gfc_statement st)
{
match m;
gfc_expr *tmp, *eventvar, *until_count, *stat, *errmsg;
bool saw_until_count, saw_stat, saw_errmsg;
tmp = eventvar = until_count = stat = errmsg = NULL;
saw_until_count = saw_stat = saw_errmsg = false;
if (gfc_pure (NULL))
{
gfc_error ("Image control statement EVENT %s at %C in PURE procedure",
st == ST_EVENT_POST ? "POST" : "WAIT");
return MATCH_ERROR;
}
gfc_unset_implicit_pure (NULL);
if (flag_coarray == GFC_FCOARRAY_NONE)
{
gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
return MATCH_ERROR;
}
if (gfc_find_state (COMP_CRITICAL))
{
gfc_error ("Image control statement EVENT %s at %C in CRITICAL block",
st == ST_EVENT_POST ? "POST" : "WAIT");
return MATCH_ERROR;
}
if (gfc_find_state (COMP_DO_CONCURRENT))
{
gfc_error ("Image control statement EVENT %s at %C in DO CONCURRENT "
"block", st == ST_EVENT_POST ? "POST" : "WAIT");
return MATCH_ERROR;
}
if (gfc_match_char ('(') != MATCH_YES)
goto syntax;
if (gfc_match ("%e", &eventvar) != MATCH_YES)
goto syntax;
m = gfc_match_char (',');
if (m == MATCH_ERROR)
goto syntax;
if (m == MATCH_NO)
{
m = gfc_match_char (')');
if (m == MATCH_YES)
goto done;
goto syntax;
}
for (;;)
{
m = gfc_match (" stat = %v", &tmp);
if (m == MATCH_ERROR)
goto syntax;
if (m == MATCH_YES)
{
if (saw_stat)
{
gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
goto cleanup;
}
stat = tmp;
saw_stat = true;
m = gfc_match_char (',');
if (m == MATCH_YES)
continue;
tmp = NULL;
break;
}
m = gfc_match (" errmsg = %v", &tmp);
if (m == MATCH_ERROR)
goto syntax;
if (m == MATCH_YES)
{
if (saw_errmsg)
{
gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
goto cleanup;
}
errmsg = tmp;
saw_errmsg = true;
m = gfc_match_char (',');
if (m == MATCH_YES)
continue;
tmp = NULL;
break;
}
m = gfc_match (" until_count = %e", &tmp);
if (m == MATCH_ERROR || st == ST_EVENT_POST)
goto syntax;
if (m == MATCH_YES)
{
if (saw_until_count)
{
gfc_error ("Redundant UNTIL_COUNT tag found at %L ",
&tmp->where);
goto cleanup;
}
until_count = tmp;
saw_until_count = true;
m = gfc_match_char (',');
if (m == MATCH_YES)
continue;
tmp = NULL;
break;
}
break;
}
if (m == MATCH_ERROR)
goto syntax;
if (gfc_match (" )%t") != MATCH_YES)
goto syntax;
done:
switch (st)
{
case ST_EVENT_POST:
new_st.op = EXEC_EVENT_POST;
break;
case ST_EVENT_WAIT:
new_st.op = EXEC_EVENT_WAIT;
break;
default:
gcc_unreachable ();
}
new_st.expr1 = eventvar;
new_st.expr2 = stat;
new_st.expr3 = errmsg;
new_st.expr4 = until_count;
return MATCH_YES;
syntax:
gfc_syntax_error (st);
cleanup:
if (until_count != tmp)
gfc_free_expr (until_count);
if (errmsg != tmp)
gfc_free_expr (errmsg);
if (stat != tmp)
gfc_free_expr (stat);
gfc_free_expr (tmp);
gfc_free_expr (eventvar);
return MATCH_ERROR;
}
match
gfc_match_event_post (void)
{
if (!gfc_notify_std (GFC_STD_F2008_TS, "EVENT POST statement at %C"))
return MATCH_ERROR;
return event_statement (ST_EVENT_POST);
}
match
gfc_match_event_wait (void)
{
if (!gfc_notify_std (GFC_STD_F2008_TS, "EVENT WAIT statement at %C"))
return MATCH_ERROR;
return event_statement (ST_EVENT_WAIT);
}
/* Match LOCK/UNLOCK statement. Syntax:
LOCK ( lock-variable [ , lock-stat-list ] )

2
gcc/fortran/match.h
View File

@ -69,6 +69,8 @@ match gfc_match_assignment (void);
match gfc_match_if (gfc_statement *);
match gfc_match_else (void);
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_block (void);
match gfc_match_associate (void);

8
gcc/fortran/module.c
View File

@ -1981,7 +1981,7 @@ enum ab_attribute
AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE,
AB_ALLOC_COMP, AB_POINTER_COMP, AB_PROC_POINTER_COMP, AB_PRIVATE_COMP,
AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_LOCK_COMP,
AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_LOCK_COMP, AB_EVENT_COMP,
AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP,
AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION,
AB_COARRAY_COMP, AB_VTYPE, AB_VTAB, AB_CONTIGUOUS, AB_CLASS_POINTER,
@ -2028,6 +2028,7 @@ static const mstring attr_bits[] =
minit ("ALLOC_COMP", AB_ALLOC_COMP),
minit ("COARRAY_COMP", AB_COARRAY_COMP),
minit ("LOCK_COMP", AB_LOCK_COMP),
minit ("EVENT_COMP", AB_EVENT_COMP),
minit ("POINTER_COMP", AB_POINTER_COMP),
minit ("PROC_POINTER_COMP", AB_PROC_POINTER_COMP),
minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
@ -2216,6 +2217,8 @@ mio_symbol_attribute (symbol_attribute *attr)
MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits);
if (attr->lock_comp)
MIO_NAME (ab_attribute) (AB_LOCK_COMP, attr_bits);
if (attr->event_comp)
MIO_NAME (ab_attribute) (AB_EVENT_COMP, attr_bits);
if (attr->zero_comp)
MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits);
if (attr->is_class)
@ -2383,6 +2386,9 @@ mio_symbol_attribute (symbol_attribute *attr)
case AB_LOCK_COMP:
attr->lock_comp = 1;
break;
case AB_EVENT_COMP:
attr->event_comp = 1;
break;
case AB_POINTER_COMP:
attr->pointer_comp = 1;
break;

69
gcc/fortran/parse.c
View File

@ -477,6 +477,8 @@ decode_statement (void)
match ("entry% ", gfc_match_entry, ST_ENTRY);
match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
match ("external", gfc_match_external, ST_ATTR_DECL);
match ("event post", gfc_match_event_post, ST_EVENT_POST);
match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT);
break;
case 'f':
@ -1348,6 +1350,7 @@ next_statement (void)
case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: \
case ST_OMP_TARGET_UPDATE: 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_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
@ -1654,6 +1657,12 @@ gfc_ascii_statement (gfc_statement st)
case ST_ELSEWHERE:
p = "ELSEWHERE";
break;
case ST_EVENT_POST:
p = "EVENT POST";
break;
case ST_EVENT_WAIT:
p = "EVENT WAIT";
break;
case ST_END_ASSOCIATE:
p = "END ASSOCIATE";
break;
@ -2646,7 +2655,7 @@ parse_derived (void)
gfc_statement st;
gfc_state_data s;
gfc_symbol *sym;
gfc_component *c, *lock_comp = NULL;
gfc_component *c, *lock_comp = NULL, *event_comp = NULL;
accept_statement (ST_DERIVED_DECL);
push_state (&s, COMP_DERIVED, gfc_new_block);
@ -2754,8 +2763,8 @@ endType:
sym = gfc_current_block ();
for (c = sym->components; c; c = c->next)
{
bool coarray, lock_type, allocatable, pointer;
coarray = lock_type = allocatable = pointer = false;
bool coarray, lock_type, event_type, allocatable, pointer;
coarray = lock_type = event_type = allocatable = pointer = false;
/* Look for allocatable components. */
if (c->attr.allocatable
@ -2817,6 +2826,23 @@ endType:
sym->attr.lock_comp = 1;
}
/* Looking for event_type components. */
if ((c->ts.type == BT_DERIVED
&& c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
&& c->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
|| (c->ts.type == BT_CLASS && c->attr.class_ok
&& CLASS_DATA (c)->ts.u.derived->from_intmod
== INTMOD_ISO_FORTRAN_ENV
&& CLASS_DATA (c)->ts.u.derived->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE)
|| (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.event_comp
&& !allocatable && !pointer))
{
event_type = 1;
event_comp = c;
sym->attr.event_comp = 1;
}
/* Check for F2008, C1302 - and recall that pointers may not be coarrays
(5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
unless there are nondirect [allocatable or pointer] components
@ -2857,6 +2883,43 @@ endType:
"coarray subcomponent)", lock_comp->name, &lock_comp->loc,
sym->name, c->name, &c->loc);
/* Similarly for EVENT TYPE. */
if (pointer && !coarray && event_type)
gfc_error ("Component %s at %L of type EVENT_TYPE must have a "
"codimension or be a subcomponent of a coarray, "
"which is not possible as the component has the "
"pointer attribute", c->name, &c->loc);
else if (pointer && !coarray && c->ts.type == BT_DERIVED
&& c->ts.u.derived->attr.event_comp)
gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
"of type EVENT_TYPE, which must have a codimension or be a "
"subcomponent of a coarray", c->name, &c->loc);
if (event_type && allocatable && !coarray)
gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have "
"a codimension", c->name, &c->loc);
else if (event_type && allocatable && c->ts.type == BT_DERIVED
&& c->ts.u.derived->attr.event_comp)
gfc_error ("Allocatable component %s at %L must have a codimension as "
"it has a noncoarray subcomponent of type EVENT_TYPE",
c->name, &c->loc);
if (sym->attr.coarray_comp && !coarray && event_type)
gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
"subcomponent of type EVENT_TYPE must have a codimension or "
"be a subcomponent of a coarray. (Variables of type %s may "
"not have a codimension as already a coarray "
"subcomponent exists)", c->name, &c->loc, sym->name);
if (sym->attr.event_comp && coarray && !event_type)
gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
"subcomponent of type EVENT_TYPE must have a codimension or "
"be a subcomponent of a coarray. (Variables of type %s may "
"not have a codimension as %s at %L has a codimension or a "
"coarray subcomponent)", event_comp->name, &event_comp->loc,
sym->name, c->name, &c->loc);
/* Look for private components. */
if (sym->component_access == ACCESS_PRIVATE
|| c->attr.access == ACCESS_PRIVATE

93
gcc/fortran/resolve.c
View File

@ -7055,6 +7055,21 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
&code->expr3->where, &e->where);
goto failure;
}
/* Check TS18508, C702/C703. */
if (code->expr3->ts.type == BT_DERIVED
&& ((codimension && gfc_expr_attr (code->expr3).event_comp)
|| (code->expr3->ts.u.derived->from_intmod
== INTMOD_ISO_FORTRAN_ENV
&& code->expr3->ts.u.derived->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE)))
{
gfc_error ("The source-expr at %L shall neither be of type "
"EVENT_TYPE nor have a EVENT_TYPE component if "
"allocate-object at %L is a coarray",
&code->expr3->where, &e->where);
goto failure;
}
}
/* Check F08:C629. */
@ -7106,6 +7121,13 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
no SOURCE exists by setting expr3. */
code->expr3 = gfc_default_initializer (&code->ext.alloc.ts);
}
else if (flag_coarray != GFC_FCOARRAY_LIB && e->ts.type == BT_DERIVED
&& e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
&& e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
{
/* We have to zero initialize the integer variable. */
code->expr3 = gfc_get_int_expr (gfc_default_integer_kind, &e->where, 0);
}
else if (!code->expr3)
{
/* Set up default initializer if needed. */
@ -8706,21 +8728,40 @@ find_reachable_labels (gfc_code *block)
static void
resolve_lock_unlock (gfc_code *code)
resolve_lock_unlock_event (gfc_code *code)
{
if (code->expr1->expr_type == EXPR_FUNCTION
&& code->expr1->value.function.isym
&& code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)
remove_caf_get_intrinsic (code->expr1);
if (code->expr1->ts.type != BT_DERIVED
|| code->expr1->expr_type != EXPR_VARIABLE
|| code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
|| code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
|| code->expr1->rank != 0
|| (!gfc_is_coarray (code->expr1) && !gfc_is_coindexed (code->expr1)))
if ((code->op == EXEC_LOCK || code->op == EXEC_UNLOCK)
&& (code->expr1->ts.type != BT_DERIVED
|| code->expr1->expr_type != EXPR_VARIABLE
|| code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV
|| code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE
|| code->expr1->rank != 0
|| (!gfc_is_coarray (code->expr1) &&
!gfc_is_coindexed (code->expr1))))
gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE",
&code->expr1->where);
else if ((code->op == EXEC_EVENT_POST && code->op == EXEC_EVENT_WAIT)
&& (code->expr1->ts.type != BT_DERIVED
|| code->expr1->expr_type != EXPR_VARIABLE
|| code->expr1->ts.u.derived->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
|| code->expr1->ts.u.derived->intmod_sym_id
!= ISOFORTRAN_EVENT_TYPE
|| code->expr1->rank != 0))
gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE",
&code->expr1->where);
else if (code->op == EXEC_EVENT_POST && !gfc_is_coarray (code->expr1)
&& !gfc_is_coindexed (code->expr1))
gfc_error ("Event variable argument at %L must be a coarray or coindexed",
&code->expr1->where);
else if (code->op == EXEC_EVENT_WAIT && !gfc_is_coarray (code->expr1))
gfc_error ("Event variable argument at %L must be a coarray but not "
"coindexed", &code->expr1->where);
/* Check STAT. */
if (code->expr2
@ -8746,17 +8787,23 @@ resolve_lock_unlock (gfc_code *code)
_("ERRMSG variable")))
return;
/* Check ACQUIRED_LOCK. */
if (code->expr4
/* Check for LOCK the ACQUIRED_LOCK. */
if (code->op != EXEC_EVENT_WAIT && code->expr4
&& (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0
|| code->expr4->expr_type != EXPR_VARIABLE))
gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL "
"variable", &code->expr4->where);
if (code->expr4
if (code->op != EXEC_EVENT_WAIT && code->expr4
&& !gfc_check_vardef_context (code->expr4, false, false, false,
_("ACQUIRED_LOCK variable")))
return;
/* Check for EVENT WAIT the UNTIL_COUNT. */
if (code->op == EXEC_EVENT_WAIT && code->expr4
&& (code->expr4->ts.type != BT_INTEGER || code->expr4->rank != 0))
gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER "
"expression", &code->expr4->where);
}
@ -10403,7 +10450,9 @@ start:
case EXEC_LOCK:
case EXEC_UNLOCK:
resolve_lock_unlock (code);
case EXEC_EVENT_POST:
case EXEC_EVENT_WAIT:
resolve_lock_unlock_event (code);
break;
case EXEC_ENTRY:
@ -14001,6 +14050,19 @@ resolve_symbol (gfc_symbol *sym)
return;
}
/* TS18508, C702/C703. */
if (sym->ts.type == BT_DERIVED
&& ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
&& sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
|| sym->ts.u.derived->attr.event_comp)
&& !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp)
{
gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of "
"type LOCK_TYPE must be a coarray", sym->name,
&sym->declared_at);
return;
}
/* An assumed-size array with INTENT(OUT) shall not be of a type for which
default initialization is defined (5.1.2.4.4). */
if (sym->ts.type == BT_DERIVED
@ -14030,6 +14092,15 @@ resolve_symbol (gfc_symbol *sym)
return;
}
/* TS18508. */
if (sym->ts.type == BT_DERIVED && sym->attr.dummy
&& sym->attr.intent == INTENT_OUT && sym->attr.event_comp)
{
gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be "
"INTENT(OUT)", sym->name, &sym->declared_at);
return;
}
/* F2008, C525. */
if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp)
|| (sym->ts.type == BT_CLASS && sym->attr.class_ok

2
gcc/fortran/st.c
View File

@ -118,6 +118,8 @@ gfc_free_statement (gfc_code *p)
case EXEC_SYNC_MEMORY:
case EXEC_LOCK:
case EXEC_UNLOCK:
case EXEC_EVENT_POST:
case EXEC_EVENT_WAIT:
break;
case EXEC_BLOCK:

28
gcc/fortran/trans-decl.c
View File

@ -145,6 +145,9 @@ tree gfor_fndecl_caf_atomic_cas;
tree gfor_fndecl_caf_atomic_op;
tree gfor_fndecl_caf_lock;
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_co_broadcast;
tree gfor_fndecl_co_max;
tree gfor_fndecl_co_min;
@ -3559,6 +3562,21 @@ gfc_build_builtin_function_decls (void)
void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
pint_type, pchar_type_node, integer_type_node);
gfor_fndecl_caf_event_post = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_event_post")), "R..WW",
void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
pint_type, pchar_type_node, integer_type_node);
gfor_fndecl_caf_event_wait = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_event_wait")), "R..WW",
void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
pint_type, pchar_type_node, integer_type_node);
gfor_fndecl_caf_event_query = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_event_query")), "R..WW",
void_type_node, 5, pvoid_type_node, size_type_node, integer_type_node,
pint_type, pint_type);
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,
@ -4854,7 +4872,7 @@ static void
generate_coarray_sym_init (gfc_symbol *sym)
{
tree tmp, size, decl, token;
bool is_lock_type;
bool is_lock_type, is_event_type;
int reg_type;
if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension
@ -4870,13 +4888,17 @@ generate_coarray_sym_init (gfc_symbol *sym)
&& sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
&& sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE;
is_event_type = sym->ts.type == BT_DERIVED
&& sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
&& sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE;
/* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108
to make sure the variable is not optimized away. */
DECL_PRESERVE_P (DECL_CONTEXT (decl)) = 1;
/* For lock types, we pass the array size as only the library knows the
size of the variable. */
if (is_lock_type)
if (is_lock_type || is_event_type)
size = gfc_index_one_node;
else
size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl)));
@ -4898,6 +4920,8 @@ generate_coarray_sym_init (gfc_symbol *sym)
GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl)));
if (is_lock_type)
reg_type = sym->attr.artificial ? GFC_CAF_CRITICAL : GFC_CAF_LOCK_STATIC;
else if (is_event_type)
reg_type = GFC_CAF_EVENT_STATIC;
else
reg_type = GFC_CAF_COARRAY_STATIC;
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 6, size,

10
gcc/fortran/trans-expr.c
View File

@ -5784,8 +5784,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
len = cl.backend_decl;
}
byref = (comp && (comp->attr.dimension || comp->ts.type == BT_CHARACTER))
|| (!comp && gfc_return_by_reference (sym));
byref = (comp && (comp->attr.dimension
|| (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
|| (!comp && gfc_return_by_reference (sym));
if (byref)
{
if (se->direct_byref)
@ -6611,6 +6612,11 @@ gfc_conv_initializer (gfc_expr * expr, gfc_typespec * ts, tree type,
{
gfc_se se;
if (flag_coarray != GFC_FCOARRAY_LIB && ts->type == BT_DERIVED
&& ts->u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
&& ts->u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
return build_constructor (type, NULL);
if (!(expr || pointer || procptr))
return NULL_TREE;

152
gcc/fortran/trans-intrinsic.c
View File

@ -9291,6 +9291,154 @@ conv_intrinsic_atomic_cas (gfc_code *code)
return gfc_finish_block (&block);
}
static tree
conv_intrinsic_event_query (gfc_code *code)
{
gfc_se se, argse;
tree stat = NULL_TREE, stat2 = NULL_TREE;
tree count = NULL_TREE, count2 = NULL_TREE;
gfc_expr *event_expr = code->ext.actual->expr;
if (code->ext.actual->next->next->expr)
{
gcc_assert (code->ext.actual->next->next->expr->expr_type
== EXPR_VARIABLE);
gfc_init_se (&argse, NULL);
gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
stat = argse.expr;
}
else if (flag_coarray == GFC_FCOARRAY_LIB)
stat = null_pointer_node;
if (code->ext.actual->next->expr)
{
gcc_assert (code->ext.actual->next->expr->expr_type == EXPR_VARIABLE);
gfc_init_se (&argse, NULL);
gfc_conv_expr_val (&argse, code->ext.actual->next->expr);
count = argse.expr;
}
gfc_start_block (&se.pre);
if (flag_coarray == GFC_FCOARRAY_LIB)
{
tree tmp, token, image_index;
tree index = size_zero_node;
if (event_expr->expr_type == EXPR_FUNCTION
&& event_expr->value.function.isym
&& event_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
event_expr = event_expr->value.function.actual->expr;
tree caf_decl = gfc_get_tree_for_caf_expr (event_expr);
if (event_expr->symtree->n.sym->ts.type != BT_DERIVED
|| event_expr->symtree->n.sym->ts.u.derived->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
|| event_expr->symtree->n.sym->ts.u.derived->intmod_sym_id
!= ISOFORTRAN_EVENT_TYPE)
{
gfc_error ("Sorry, the event component of derived type at %L is not "
"yet supported", &event_expr->where);
return NULL_TREE;
}
if (gfc_is_coindexed (event_expr))
{
gfc_error ("The event variable at %L shall not be coindexed ",
&event_expr->where);
return NULL_TREE;
}
image_index = integer_zero_node;
gfc_get_caf_token_offset (&token, NULL, caf_decl, NULL_TREE, event_expr);
/* For arrays, obtain the array index. */
if (gfc_expr_attr (event_expr).dimension)
{
tree desc, tmp, extent, lbound, ubound;
gfc_array_ref *ar, ar2;
int i;
/* TODO: Extend this, once DT components are supported. */
ar = &event_expr->ref->u.ar;
ar2 = *ar;
memset (ar, '\0', sizeof (*ar));
ar->as = ar2.as;
ar->type = AR_FULL;
gfc_init_se (&argse, NULL);
argse.descriptor_only = 1;
gfc_conv_expr_descriptor (&argse, event_expr);
gfc_add_block_to_block (&se.pre, &argse.pre);
desc = argse.expr;
*ar = ar2;
extent = integer_one_node;
for (i = 0; i < ar->dimen; i++)
{
gfc_init_se (&argse, NULL);
gfc_conv_expr_type (&argse, ar->start[i], integer_type_node);
gfc_add_block_to_block (&argse.pre, &argse.pre);
lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
integer_type_node, argse.expr,
fold_convert(integer_type_node, lbound));
tmp = fold_build2_loc (input_location, MULT_EXPR,
integer_type_node, extent, tmp);
index = fold_build2_loc (input_location, PLUS_EXPR,
integer_type_node, index, tmp);
if (i < ar->dimen - 1)
{
ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
tmp = fold_convert (integer_type_node, tmp);
extent = fold_build2_loc (input_location, MULT_EXPR,
integer_type_node, extent, tmp);
}
}
}
if (count != null_pointer_node && TREE_TYPE (count) != integer_type_node)
{
count2 = count;
count = gfc_create_var (integer_type_node, "count");
}
if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
{
stat2 = stat;
stat = gfc_create_var (integer_type_node, "stat");
}
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_query, 5,
token, index, image_index, count
? gfc_build_addr_expr (NULL, count) : count,
stat != null_pointer_node
? gfc_build_addr_expr (NULL, stat) : stat);
gfc_add_expr_to_block (&se.pre, tmp);
if (count2 != NULL_TREE)
gfc_add_modify (&se.pre, count2,
fold_convert (TREE_TYPE (count2), count));
if (stat2 != NULL_TREE)
gfc_add_modify (&se.pre, stat2,
fold_convert (TREE_TYPE (stat2), stat));
return gfc_finish_block (&se.pre);
}
gfc_init_se (&argse, NULL);
gfc_conv_expr_val (&argse, code->ext.actual->expr);
gfc_add_modify (&se.pre, count, fold_convert (TREE_TYPE (count), argse.expr));
if (stat != NULL_TREE)
gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
return gfc_finish_block (&se.pre);
}
static tree
conv_intrinsic_move_alloc (gfc_code *code)
@ -9587,6 +9735,10 @@ gfc_conv_intrinsic_subroutine (gfc_code *code)
res = conv_intrinsic_atomic_ref (code);
break;
case GFC_ISYM_EVENT_QUERY:
res = conv_intrinsic_event_query (code);
break;
case GFC_ISYM_C_F_POINTER:
case GFC_ISYM_C_F_PROCPOINTER:
res = conv_isocbinding_subroutine (code);

161
gcc/fortran/trans-stmt.c
View File

@ -776,6 +776,7 @@ gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op)
if (code->expr3)
{
gfc_init_se (&argse, NULL);
argse.want_pointer = 1;
gfc_conv_expr (&argse, code->expr3);
gfc_add_block_to_block (&se.pre, &argse.pre);
errmsg = argse.expr;
@ -840,6 +841,165 @@ gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op)
return gfc_finish_block (&se.pre);
}
tree
gfc_trans_event_post_wait (gfc_code *code, gfc_exec_op op)
{
gfc_se se, argse;
tree stat = NULL_TREE, stat2 = NULL_TREE;
tree until_count = NULL_TREE;
if (code->expr2)
{
gcc_assert (code->expr2->expr_type == EXPR_VARIABLE);
gfc_init_se (&argse, NULL);
gfc_conv_expr_val (&argse, code->expr2);
stat = argse.expr;
}
else if (flag_coarray == GFC_FCOARRAY_LIB)
stat = null_pointer_node;
if (code->expr4)
{
gfc_init_se (&argse, NULL);
gfc_conv_expr_val (&argse, code->expr4);
until_count = fold_convert (integer_type_node, argse.expr);
}
else
until_count = integer_one_node;
if (flag_coarray != GFC_FCOARRAY_LIB)
{
gfc_start_block (&se.pre);
gfc_init_se (&argse, NULL);
gfc_conv_expr_val (&argse, code->expr1);
if (op == EXEC_EVENT_POST)
gfc_add_modify (&se.pre, argse.expr,
fold_build2_loc (input_location, PLUS_EXPR,
TREE_TYPE (argse.expr), argse.expr,
build_int_cst (TREE_TYPE (argse.expr), 1)));
else
gfc_add_modify (&se.pre, argse.expr,
fold_build2_loc (input_location, MINUS_EXPR,
TREE_TYPE (argse.expr), argse.expr,
fold_convert (TREE_TYPE (argse.expr),
until_count)));
if (stat != NULL_TREE)
gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
return gfc_finish_block (&se.pre);
}
gfc_start_block (&se.pre);
tree tmp, token, image_index, errmsg, errmsg_len;
tree index = size_zero_node;
tree caf_decl = gfc_get_tree_for_caf_expr (code->expr1);
if (code->expr1->symtree->n.sym->ts.type != BT_DERIVED
|| code->expr1->symtree->n.sym->ts.u.derived->from_intmod
!= INTMOD_ISO_FORTRAN_ENV
|| code->expr1->symtree->n.sym->ts.u.derived->intmod_sym_id
!= ISOFORTRAN_EVENT_TYPE)
{
gfc_error ("Sorry, the event component of derived type at %L is not "
"yet supported", &code->expr1->where);
return NULL_TREE;
}
gfc_get_caf_token_offset (&token, NULL, caf_decl, NULL_TREE, code->expr1);
if (gfc_is_coindexed (code->expr1))
image_index = gfc_caf_get_image_index (&se.pre, code->expr1, caf_decl);
else
image_index = integer_zero_node;
/* For arrays, obtain the array index. */
if (gfc_expr_attr (code->expr1).dimension)
{
tree desc, tmp, extent, lbound, ubound;
gfc_array_ref *ar, ar2;
int i;
/* TODO: Extend this, once DT components are supported. */
ar = &code->expr1->ref->u.ar;
ar2 = *ar;
memset (ar, '\0', sizeof (*ar));
ar->as = ar2.as;
ar->type = AR_FULL;
gfc_init_se (&argse, NULL);
argse.descriptor_only = 1;
gfc_conv_expr_descriptor (&argse, code->expr1);
gfc_add_block_to_block (&se.pre, &argse.pre);
desc = argse.expr;
*ar = ar2;
extent = integer_one_node;
for (i = 0; i < ar->dimen; i++)
{
gfc_init_se (&argse, NULL);
gfc_conv_expr_type (&argse, ar->start[i], integer_type_node);
gfc_add_block_to_block (&argse.pre, &argse.pre);
lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
tmp = fold_build2_loc (input_location, MINUS_EXPR,
integer_type_node, argse.expr,
fold_convert(integer_type_node, lbound));
tmp = fold_build2_loc (input_location, MULT_EXPR,
integer_type_node, extent, tmp);
index = fold_build2_loc (input_location, PLUS_EXPR,
integer_type_node, index, tmp);
if (i < ar->dimen - 1)
{
ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
tmp = fold_convert (integer_type_node, tmp);
extent = fold_build2_loc (input_location, MULT_EXPR,
integer_type_node, extent, tmp);
}
}
}
/* errmsg. */
if (code->expr3)
{
gfc_init_se (&argse, NULL);
argse.want_pointer = 1;
gfc_conv_expr (&argse, code->expr3);
gfc_add_block_to_block (&se.pre, &argse.pre);
errmsg = argse.expr;
errmsg_len = fold_convert (integer_type_node, argse.string_length);
}
else
{
errmsg = null_pointer_node;
errmsg_len = integer_zero_node;
}
if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
{
stat2 = stat;
stat = gfc_create_var (integer_type_node, "stat");
}
if (op == EXEC_EVENT_POST)
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_post, 6,
token, index, image_index,
stat != null_pointer_node
? gfc_build_addr_expr (NULL, stat) : stat,
errmsg, errmsg_len);
else
tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_wait, 6,
token, index, until_count,
stat != null_pointer_node
? gfc_build_addr_expr (NULL, stat) : stat,
errmsg, errmsg_len);
gfc_add_expr_to_block (&se.pre, tmp);
if (stat2 != NULL_TREE)
gfc_add_modify (&se.pre, stat2, fold_convert (TREE_TYPE (stat2), stat));
return gfc_finish_block (&se.pre);
}
tree
gfc_trans_sync (gfc_code *code, gfc_exec_op type)
@ -879,6 +1039,7 @@ gfc_trans_sync (gfc_code *code, gfc_exec_op type)
{
gcc_assert (code->expr3->expr_type == EXPR_VARIABLE);
gfc_init_se (&argse, NULL);
argse.want_pointer = 1;
gfc_conv_expr (&argse, code->expr3);
gfc_conv_string_parameter (&argse);
errmsg = gfc_build_addr_expr (NULL, argse.expr);

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

@ -55,6 +55,7 @@ tree gfc_trans_do_while (gfc_code *);
tree gfc_trans_select (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_forall (gfc_code *);
tree gfc_trans_where (gfc_code *);
tree gfc_trans_allocate (gfc_code *);

5
gcc/fortran/trans-types.c
View File

@ -2371,6 +2371,11 @@ gfc_get_derived_type (gfc_symbol * derived)
&& derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE))
return ptr_type_node;
if (flag_coarray != GFC_FCOARRAY_LIB
&& derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
&& derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
return gfc_get_int_type (gfc_default_integer_kind);
if (derived && derived->attr.flavor == FL_PROCEDURE
&& derived->attr.generic)
derived = gfc_find_dt_in_generic (derived);

17
gcc/fortran/trans.c
View File

@ -711,7 +711,7 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree pointer,
static void
gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size,
tree token, tree status, tree errmsg, tree errlen,
bool lock_var)
bool lock_var, bool event_var)
{
tree tmp, pstat;
@ -738,7 +738,8 @@ gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size,
build_int_cst (size_type_node, 1)),
build_int_cst (integer_type_node,
lock_var ? GFC_CAF_LOCK_ALLOC
: GFC_CAF_COARRAY_ALLOC),
: event_var ? GFC_CAF_EVENT_ALLOC
: GFC_CAF_COARRAY_ALLOC),
token, pstat, errmsg, errlen);
tmp = fold_build2_loc (input_location, MODIFY_EXPR,
@ -798,6 +799,11 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree token,
== INTMOD_ISO_FORTRAN_ENV
&& expr->ts.u.derived->intmod_sym_id
== ISOFORTRAN_LOCK_TYPE;
bool event_var = expr->ts.type == BT_DERIVED
&& expr->ts.u.derived->from_intmod
== INTMOD_ISO_FORTRAN_ENV
&& expr->ts.u.derived->intmod_sym_id
== ISOFORTRAN_EVENT_TYPE;
/* In the front end, we represent the lock variable as pointer. However,
the FE only passes the pointer around and leaves the actual
representation to the library. Hence, we have to convert back to the
@ -807,7 +813,7 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree token,
size, TYPE_SIZE_UNIT (ptr_type_node));
gfc_allocate_using_lib (&alloc_block, mem, size, token, status,
errmsg, errlen, lock_var);
errmsg, errlen, lock_var, event_var);
if (status != NULL_TREE)
{
@ -1797,6 +1803,11 @@ trans_code (gfc_code * code, tree cond)
res = gfc_trans_lock_unlock (code, code->op);
break;
case EXEC_EVENT_POST:
case EXEC_EVENT_WAIT:
res = gfc_trans_event_post_wait (code, code->op);
break;
case EXEC_FORALL:
res = gfc_trans_forall (code);
break;

7
gcc/fortran/trans.h
View File

@ -113,7 +113,9 @@ enum gfc_coarray_type
GFC_CAF_COARRAY_ALLOC,
GFC_CAF_LOCK_STATIC,
GFC_CAF_LOCK_ALLOC,
GFC_CAF_CRITICAL
GFC_CAF_CRITICAL,
GFC_CAF_EVENT_STATIC,
GFC_CAF_EVENT_ALLOC
};
@ -763,6 +765,9 @@ extern GTY(()) tree gfor_fndecl_caf_atomic_cas;
extern GTY(()) tree gfor_fndecl_caf_atomic_op;
extern GTY(()) tree gfor_fndecl_caf_lock;
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_co_broadcast;
extern GTY(()) tree gfor_fndecl_co_max;
extern GTY(()) tree gfor_fndecl_co_min;

6
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
2015-12-02 Tobias Burnus <burnus@net-b.de>
Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>
* gfortran.dg/coarray/event_1.f90: New.
* gfortran.dg/coarray/event_2.f90: New.
2015-12-02 Aditya Kumar <aditya.k7@samsung.com>
Sebastian Pop <s.pop@samsung.com>

51
gcc/testsuite/gfortran.dg/coarray/event_1.f90 Normal file
View File

@ -0,0 +1,51 @@
! { dg-do run }
!
! Run-time test for EVENT_TYPE
!
use iso_fortran_env, only: event_type
implicit none
type(event_type), save :: var[*]
integer :: count, stat
count = -42
call event_query (var, count)
if (count /= 0) call abort()
stat = 99
event post (var, stat=stat)
if (stat /= 0) call abort()
call event_query(var, count, stat=stat)
if (count /= 1 .or. stat /= 0) call abort()
stat = 99
event post (var[this_image()])
call event_query(var, count)
if (count /= 2) call abort()
stat = 99
event wait (var)
call event_query(var, count)
if (count /= 1) call abort()
stat = 99
event post (var)
call event_query(var, count)
if (count /= 2) call abort()
stat = 99
event post (var)
call event_query(var, count)
if (count /= 3) call abort()
stat = 99
event wait (var, until_count=2)
call event_query(var, count)
if (count /= 1) call abort()
stat = 99
event wait (var, stat=stat, until_count=1)
if (stat /= 0) call abort()
call event_query(event=var, stat=stat, count=count)
if (count /= 0 .or. stat /= 0) call abort()
end

89
gcc/testsuite/gfortran.dg/coarray/event_2.f90 Normal file
View File

@ -0,0 +1,89 @@
! { dg-do run }
!
! Run-time test for EVENT_TYPE
!
use iso_fortran_env, only: event_type
implicit none
type(event_type), save, allocatable :: var(:)[:]
integer :: count, stat
allocate(var(3)[*])
count = -42
call event_query (var(1), count)
if (count /= 0) call abort()
call event_query (var(1), count)
if (count /= 0) call abort()
call event_query (var(2), count)
if (count /= 0) call abort()
call event_query (var(3), count)
if (count /= 0) call abort()
stat = 99
event post (var(2), stat=stat)
if (stat /= 0) call abort()
call event_query (var(1), count)
if (count /= 0) call abort()
call event_query(var(2), count, stat=stat)
if (count /= 1 .or. stat /= 0) call abort()
call event_query (var(3), count)
if (count /= 0) call abort()
stat = 99
event post (var(2)[this_image()])
call event_query(var(1), count)
if (count /= 0) call abort()
call event_query(var(2), count)
if (count /= 2) call abort()
call event_query(var(2), count)
if (count /= 2) call abort()
call event_query(var(3), count)
if (count /= 0) call abort()
stat = 99
event wait (var(2))
call event_query(var(1), count)
if (count /= 0) call abort()
call event_query(var(2), count)
if (count /= 1) call abort()
call event_query(var(3), count)
if (count /= 0) call abort()
stat = 99
event post (var(2))
call event_query(var(1), count)
if (count /= 0) call abort()
call event_query(var(2), count)
if (count /= 2) call abort()
call event_query(var(3), count)
if (count /= 0) call abort()
stat = 99
event post (var(2))
call event_query(var(1), count)
if (count /= 0) call abort()
call event_query(var(2), count)
if (count /= 3) call abort()
call event_query(var(3), count)
if (count /= 0) call abort()
stat = 99
event wait (var(2), until_count=2)
call event_query(var(1), count)
if (count /= 0) call abort()
call event_query(var(2), count)
if (count /= 1) call abort()
call event_query(var(3), count)
if (count /= 0) call abort()
stat = 99
event wait (var(2), stat=stat, until_count=1)
if (stat /= 0) call abort()
call event_query(event=var(1), stat=stat, count=count)
if (count /= 0 .or. stat /= 0) call abort()
call event_query(event=var(2), stat=stat, count=count)
if (count /= 0 .or. stat /= 0) call abort()
call event_query(event=var(3), stat=stat, count=count)
if (count /= 0 .or. stat /= 0) call abort()
end

8
libgfortran/ChangeLog
View File

@ -1,3 +1,11 @@
2015-11-26 Tobias Burnus <burnus@net-b.de>
Alessandro Fanfarillo <fanfarillo.gcc@gmail.com>
* caf/libcaf.h (_gfortran_caf_event_post,
_gfortran_caf_event_wait,_gfortran_caf_event_query): New prototypes.
* caf/single.c (_gfortran_caf_event_post,
_gfortran_caf_event_wait,_gfortran_caf_event_query): Implement.
2015-11-22 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR libfortran/52251

7
libgfortran/caf/libcaf.h
View File

@ -57,7 +57,9 @@ typedef enum caf_register_t {
CAF_REGTYPE_COARRAY_ALLOC,
CAF_REGTYPE_LOCK_STATIC,
CAF_REGTYPE_LOCK_ALLOC,
CAF_REGTYPE_CRITICAL
CAF_REGTYPE_CRITICAL,
CAF_REGTYPE_EVENT_STATIC,
CAF_REGTYPE_EVENT_ALLOC
}
caf_register_t;
@ -133,5 +135,8 @@ void _gfortran_caf_atomic_op (int, caf_token_t, size_t, int, void *, void *,
void _gfortran_caf_lock (caf_token_t, size_t, int, int *, int *, char *, int);
void _gfortran_caf_unlock (caf_token_t, size_t, int, int *, char *, int);
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 *);
#endif /* LIBCAF_H */

45
libgfortran/caf/single.c
View File

@ -101,7 +101,8 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
void *local;
if (type == CAF_REGTYPE_LOCK_STATIC || type == CAF_REGTYPE_LOCK_ALLOC
|| type == CAF_REGTYPE_CRITICAL)
|| type == CAF_REGTYPE_CRITICAL || type == CAF_REGTYPE_EVENT_STATIC
|| type == CAF_REGTYPE_EVENT_ALLOC)
local = calloc (size, sizeof (bool));
else
local = malloc (size);
@ -133,7 +134,8 @@ _gfortran_caf_register (size_t size, caf_register_t type, caf_token_t *token,
*stat = 0;
if (type == CAF_REGTYPE_COARRAY_STATIC || type == CAF_REGTYPE_LOCK_STATIC
|| type == CAF_REGTYPE_CRITICAL)
|| type == CAF_REGTYPE_CRITICAL || type == CAF_REGTYPE_EVENT_STATIC
|| type == CAF_REGTYPE_EVENT_ALLOC)
{
caf_static_t *tmp = malloc (sizeof (caf_static_t));
tmp->prev = caf_static_list;
@ -1071,6 +1073,45 @@ _gfortran_caf_atomic_op (int op, caf_token_t token, size_t offset,
*stat = 0;
}
void
_gfortran_caf_event_post (caf_token_t token, size_t index,
int image_index __attribute__ ((unused)),
int *stat, char *errmsg __attribute__ ((unused)),
int errmsg_len __attribute__ ((unused)))
{
uint32_t value = 1;
uint32_t *event = (uint32_t *) ((char *) TOKEN (token) + index*sizeof(uint32_t));
__atomic_fetch_add (event, (uint32_t) value, __ATOMIC_RELAXED);
if(stat)
*stat = 0;
}
void
_gfortran_caf_event_wait (caf_token_t token, size_t index,
int until_count, int *stat,
char *errmsg __attribute__ ((unused)),
int errmsg_len __attribute__ ((unused)))
{
uint32_t *event = (uint32_t *) ((char *) TOKEN (token) + index*sizeof(uint32_t));
uint32_t value = (uint32_t)-until_count;
__atomic_fetch_add (event, (uint32_t) value, __ATOMIC_RELAXED);
if(stat)
*stat = 0;
}
void
_gfortran_caf_event_query (caf_token_t token, size_t index,
int image_index __attribute__ ((unused)),
int *count, int *stat)
{
uint32_t *event = (uint32_t *) ((char *) TOKEN (token) + index*sizeof(uint32_t));
__atomic_load (event, (uint32_t *) count, __ATOMIC_RELAXED);
if(stat)
*stat = 0;
}
void
_gfortran_caf_lock (caf_token_t token, size_t index,