+2014-09-25 Tobias Burnus <burnus@net-b.de>
+
+ * check.c (check_co_collective): Renamed from check_co_minmaxsum,
+ handle co_reduce.
+ (gfc_check_co_minmax, gfc_check_co_sum): Update call.
+ (gfc_check_co_broadcast, gfc_check_co_reduce): New.
+ * gfortran.h (gfc_isym_id): Add GFC_ISYM_CO_BROADCAST and
+ GFC_ISYM_CO_REDUCE.
+ * intrinsic.c (add_subroutines): Add co_reduce and co_broadcast.
+ * intrinsic.h (gfc_check_co_broadcast, gfc_check_co_reduce): Add
+ proto types.
+ * intrinsic.texi (CO_BROADCAST): Add.
+ * trans.h (gfor_fndecl_co_broadcast): New.
+ * trans-decl.c (gfor_fndecl_co_broadcast): Ditto.
+ (gfc_build_builtin_function_decls): Add decl for it,
+ * trans-intrinsic.c (conv_co_collective): Renamed from
+ conv_co_minmaxsum. Handle co_reduce.
+ (gfc_conv_intrinsic_subroutine): Handle co_reduce.
+
2014-09-23 Jakub Jelinek <jakub@redhat.com>
PR fortran/63331
static bool
-check_co_minmaxsum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
- gfc_expr *errmsg)
+check_co_collective (gfc_expr *a, gfc_expr *image_idx, gfc_expr *stat,
+ gfc_expr *errmsg, bool co_reduce)
{
if (!variable_check (a, 0, false))
return false;
"INTENT(INOUT)"))
return false;
+ /* Fortran 2008, 12.5.2.4, paragraph 18. */
if (gfc_has_vector_subscript (a))
{
gfc_error ("Argument 'A' with INTENT(INOUT) at %L of the intrinsic "
return false;
}
- if (result_image != NULL)
+ if (image_idx != NULL)
{
- if (!type_check (result_image, 1, BT_INTEGER))
+ if (!type_check (image_idx, co_reduce ? 2 : 1, BT_INTEGER))
return false;
- if (!scalar_check (result_image, 1))
+ if (!scalar_check (image_idx, co_reduce ? 2 : 1))
return false;
}
if (stat != NULL)
{
- if (!type_check (stat, 2, BT_INTEGER))
+ if (!type_check (stat, co_reduce ? 3 : 2, BT_INTEGER))
return false;
- if (!scalar_check (stat, 2))
+ if (!scalar_check (stat, co_reduce ? 3 : 2))
return false;
- if (!variable_check (stat, 2, false))
+ if (!variable_check (stat, co_reduce ? 3 : 2, false))
return false;
if (stat->ts.kind != 4)
{
if (errmsg != NULL)
{
- if (!type_check (errmsg, 3, BT_CHARACTER))
+ if (!type_check (errmsg, co_reduce ? 4 : 3, BT_CHARACTER))
return false;
- if (!scalar_check (errmsg, 3))
+ if (!scalar_check (errmsg, co_reduce ? 4 : 3))
return false;
- if (!variable_check (errmsg, 3, false))
+ if (!variable_check (errmsg, co_reduce ? 4 : 3, false))
return false;
if (errmsg->ts.kind != 1)
{
}
+bool
+gfc_check_co_broadcast (gfc_expr *a, gfc_expr *source_image, gfc_expr *stat,
+ gfc_expr *errmsg)
+{
+ if (a->ts.type == BT_CLASS || gfc_expr_attr (a).alloc_comp)
+ {
+ gfc_error ("Support for the A argument at %L which is polymorphic A "
+ "argument or has allocatable components is not yet "
+ "implemented", &a->where);
+ return false;
+ }
+ return check_co_collective (a, source_image, stat, errmsg, false);
+}
+
+
+bool
+gfc_check_co_reduce (gfc_expr *a, gfc_expr *op, gfc_expr *result_image,
+ gfc_expr *stat, gfc_expr *errmsg)
+{
+ symbol_attribute attr;
+
+ if (a->ts.type == BT_CLASS)
+ {
+ gfc_error ("The A argument at %L of CO_REDUCE shall not be polymorphic",
+ &a->where);
+ return false;
+ }
+
+ if (gfc_expr_attr (a).alloc_comp)
+ {
+ gfc_error ("Support for the A argument at %L with allocatable components"
+ " is not yet implemented", &a->where);
+ return false;
+ }
+
+ attr = gfc_expr_attr (op);
+ if (!attr.pure || !attr.function)
+ {
+ gfc_error ("OPERATOR argument at %L must be a PURE function",
+ &op->where);
+ return false;
+ }
+
+ if (!check_co_collective (a, result_image, stat, errmsg, true))
+ return false;
+
+ /* FIXME: After J3/WG5 has decided what they actually exactly want, more
+ checks such as same-argument checks have to be added, implemented and
+ intrinsic.texi upated. */
+
+ gfc_error("CO_REDUCE at %L is not yet implemented", &a->where);
+ return false;
+}
+
+
bool
gfc_check_co_minmax (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
gfc_expr *errmsg)
&a->where);
return false;
}
- return check_co_minmaxsum (a, result_image, stat, errmsg);
+ return check_co_collective (a, result_image, stat, errmsg, false);
}
{
if (!numeric_check (a, 0))
return false;
- return check_co_minmaxsum (a, result_image, stat, errmsg);
+ return check_co_collective (a, result_image, stat, errmsg, false);
}
GFC_ISYM_CHDIR,
GFC_ISYM_CHMOD,
GFC_ISYM_CMPLX,
+ GFC_ISYM_CO_BROADCAST,
GFC_ISYM_CO_MAX,
GFC_ISYM_CO_MIN,
+ GFC_ISYM_CO_REDUCE,
GFC_ISYM_CO_SUM,
GFC_ISYM_COMMAND_ARGUMENT_COUNT,
GFC_ISYM_COMPILER_OPTIONS,
make_from_module();
/* Coarray collectives. */
+ add_sym_4s ("co_broadcast", GFC_ISYM_CO_BROADCAST, CLASS_IMPURE,
+ BT_UNKNOWN, 0, GFC_STD_F2008_TS,
+ gfc_check_co_broadcast, NULL, NULL,
+ a, BT_REAL, dr, REQUIRED, INTENT_INOUT,
+ "source_image", BT_INTEGER, di, REQUIRED, INTENT_IN,
+ stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
+ errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT);
+
add_sym_4s ("co_max", GFC_ISYM_CO_MAX, CLASS_IMPURE,
BT_UNKNOWN, 0, GFC_STD_F2008_TS,
gfc_check_co_minmax, NULL, NULL,
stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT);
+ add_sym_5s ("co_reduce", GFC_ISYM_CO_REDUCE, CLASS_IMPURE,
+ BT_UNKNOWN, 0, GFC_STD_F2008_TS,
+ gfc_check_co_reduce, NULL, NULL,
+ a, BT_REAL, dr, REQUIRED, INTENT_INOUT,
+ "operator", BT_INTEGER, di, REQUIRED, INTENT_IN,
+ result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN,
+ stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
+ errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT);
+
+
/* The following subroutine is internally used for coarray libray functions.
"make_from_module" makes it inaccessible for external users. */
add_sym_2s (GFC_PREFIX ("caf_send"), GFC_ISYM_CAF_SEND, CLASS_IMPURE,
bool gfc_check_chmod (gfc_expr *, gfc_expr *);
bool gfc_check_cmplx (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_complex (gfc_expr *, gfc_expr *);
+bool gfc_check_co_broadcast (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_co_minmax (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_co_sum (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
+bool gfc_check_co_reduce (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
+ gfc_expr *);
bool gfc_check_count (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_cshift (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_ctime (gfc_expr *);
* @code{CHDIR}: CHDIR, Change working directory
* @code{CHMOD}: CHMOD, Change access permissions of files
* @code{CMPLX}: CMPLX, Complex conversion function
+* @code{CO_BROADCAST}: CO_BROADCAST, Copy a value to all images the current set of images
* @code{CO_MAX}: CO_MAX, Maximal value on the current set of images
* @code{CO_MIN}: CO_MIN, Minimal value on the current set of images
* @code{CO_SUM}: CO_SUM, Sum of values on the current set of images
+@node CO_BROADCAST
+@section @code{CO_BROADCAST} --- Copy a value to all images the current set of images
+@fnindex CO_BROADCAST
+@cindex Collectives, value broadcasting
+
+@table @asis
+@item @emph{Description}:
+@code{CO_BROADCAST} copies the value of argument @var{A} on the image with
+image index @code{SOURCE_IMAGE} to all images in the current team. @var{A}
+becomes defined as if by intrinsic assignment. If the execution was
+successful and @var{STAT} is present, it is assigned the value zero. If the
+execution failed, @var{STAT} gets assigned a nonzero value and, if present,
+@var{ERRMSG} gets assigned a value describing the occurred error.
+
+@item @emph{Standard}:
+Technical Specification (TS) 18508 or later
+
+@item @emph{Class}:
+Collective subroutine
+
+@item @emph{Syntax}:
+@code{CALL CO_BROADCAST(A, SOURCE_IMAGE [, STAT, ERRMSG])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{A} @tab INTENT(INOUT) argument; shall have the same
+dynamic type and type paramters on all images of the current team. If it
+is an array, it shall have the same shape on all images.
+@item @var{SOURCE_IMAGE} @tab (optional) a scalar integer expression.
+It shall have the same the same value on all images and refer to an
+image of the current team.
+@item @var{STAT} @tab (optional) a scalar integer variable
+@item @var{ERRMSG} @tab (optional) a scalar character variable
+@end multitable
+
+@item @emph{Example}:
+@smallexample
+program test
+ integer :: val(3)
+ if (this_image() == 1) then
+ val = [1, 5, 3]
+ end if
+ call co_broadcast (val, source_image=1)
+ print *, this_image, ":", val
+end program test
+@end smallexample
+
+@item @emph{See also}:
+@ref{CO_MAX}, @ref{CO_MIN}, @ref{CO_SUM}
+@end table
+
+
+
@node CO_MAX
@section @code{CO_MAX} --- Maximal value on the current set of images
@fnindex CO_MAX
@end smallexample
@item @emph{See also}:
-@ref{CO_MIN}, @ref{CO_SUM}
+@ref{CO_MIN}, @ref{CO_SUM}, @ref{CO_BROADCAST}
@end table
@end smallexample
@item @emph{See also}:
-@ref{CO_MAX}, @ref{CO_SUM}
+@ref{CO_MAX}, @ref{CO_SUM}, @ref{CO_BROADCAST}
@end table
@end smallexample
@item @emph{See also}:
-@ref{CO_MAX}, @ref{CO_MIN}
+@ref{CO_MAX}, @ref{CO_MIN}, @ref{CO_BROADCAST}
@end table
tree gfor_fndecl_caf_atomic_op;
tree gfor_fndecl_caf_lock;
tree gfor_fndecl_caf_unlock;
+tree gfor_fndecl_co_broadcast;
tree gfor_fndecl_co_max;
tree gfor_fndecl_co_min;
tree gfor_fndecl_co_sum;
void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node,
pint_type, pchar_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,
+ pint_type, pchar_type_node, integer_type_node);
+
gfor_fndecl_co_max = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_co_max")), "W.WW",
void_type_node, 6, pvoid_type_node, integer_type_node,
static tree
-conv_co_minmaxsum (gfc_code *code)
+conv_co_collective (gfc_code *code)
{
gfc_se argse;
stmtblock_t block, post_block;
}
/* Generate the function call. */
- if (code->resolved_isym->id == GFC_ISYM_CO_MAX)
- fndecl = gfor_fndecl_co_max;
- else if (code->resolved_isym->id == GFC_ISYM_CO_MIN)
- fndecl = gfor_fndecl_co_min;
- else if (code->resolved_isym->id == GFC_ISYM_CO_SUM)
- fndecl = gfor_fndecl_co_sum;
- else
- gcc_unreachable ();
+ switch (code->resolved_isym->id)
+ {
+ case GFC_ISYM_CO_BROADCAST:
+ fndecl = gfor_fndecl_co_broadcast;
+ break;
+ case GFC_ISYM_CO_MAX:
+ fndecl = gfor_fndecl_co_max;
+ break;
+ case GFC_ISYM_CO_MIN:
+ fndecl = gfor_fndecl_co_min;
+ break;
+ case GFC_ISYM_CO_SUM:
+ fndecl = gfor_fndecl_co_sum;
+ break;
+ default:
+ gcc_unreachable ();
+ }
- if (code->resolved_isym->id == GFC_ISYM_CO_SUM)
+ if (code->resolved_isym->id == GFC_ISYM_CO_SUM
+ || code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
fndecl = build_call_expr_loc (input_location, fndecl, 5, array,
image_index, stat, errmsg, errmsg_len);
else
gfc_add_expr_to_block (&block, fndecl);
gfc_add_block_to_block (&block, &post_block);
- /* Add CALL to CO_SUM/MIN/MAX: array descriptor, vector descriptor, stat, errmsg, strlen, errmsglen */
return gfc_finish_block (&block);
}
res = conv_caf_send (code);
break;
+ case GFC_ISYM_CO_REDUCE:
+ gcc_unreachable ();
+ break;
+ case GFC_ISYM_CO_BROADCAST:
case GFC_ISYM_CO_MIN:
case GFC_ISYM_CO_MAX:
case GFC_ISYM_CO_SUM:
- res = conv_co_minmaxsum (code);
+ res = conv_co_collective (code);
break;
case GFC_ISYM_SYSTEM_CLOCK:
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_co_broadcast;
extern GTY(()) tree gfor_fndecl_co_max;
extern GTY(()) tree gfor_fndecl_co_min;
extern GTY(()) tree gfor_fndecl_co_sum;
+2014-09-25 Tobias Burnus <burnus@net-b.de>
+
+ * gfortran.dg/coarray/collectives_3.f90: New.
+ * gfortran.dg/coarray_collectives_9.f90: New.
+ * gfortran.dg/coarray_collectives_10.f90: New.
+ * gfortran.dg/coarray_collectives_11.f90: New.
+ * gfortran.dg/coarray_collectives_12.f90: New.
+
2014-09-24 Bill Schmidt <wschmidt@linux.vnet.ibm.com>
* gcc.target/powerpc/swaps-p8-17.c: New test.
--- /dev/null
+! { dg-do run }
+!
+! CO_BROADCAST
+!
+program test
+ implicit none
+ intrinsic co_broadcast
+
+ type t
+ integer :: i
+ character(len=1) :: c
+ real(8) :: x(3), y(3)
+ end type t
+
+ integer :: i, j(10), stat
+ complex :: a(5,5)
+ character(kind=1, len=5) :: str1, errstr
+ character(kind=4, len=8) :: str2(2)
+ type(t) :: dt(4)
+
+ i = 1
+ j = 55
+ a = 99.0
+ str1 = 1_"XXXXX"
+ str2 = 4_"YYYYYYYY"
+ dt = t(1, 'C', [1.,2.,3.], [3,3,3])
+ errstr = "ZZZZZ"
+
+ if (this_image() == num_images()) then
+ i = 2
+ j = 66
+ a = -99.0
+ str1 = 1_"abcd"
+ str2 = 4_"12 3 4 5"
+ dt = t(-1, 'a', [3.,1.,8.], [99,24,5])
+ end if
+ sync all
+
+ call co_broadcast(i, source_image=num_images(), stat=stat, errmsg=errstr)
+ if (stat /= 0) call abort()
+ if (errstr /= "ZZZZZ") call abort()
+ if (i /= 2) call abort()
+
+ call co_broadcast(j, source_image=num_images(), stat=stat, errmsg=errstr)
+ if (stat /= 0) call abort()
+ if (errstr /= "ZZZZZ") call abort()
+ if (any (j /= 66)) call abort
+
+ call co_broadcast(a, source_image=num_images(), stat=stat, errmsg=errstr)
+ if (stat /= 0) call abort()
+ if (errstr /= "ZZZZZ") call abort()
+ if (any (a /= -99.0)) call abort
+
+ call co_broadcast(str1, source_image=num_images(), stat=stat, errmsg=errstr)
+ if (stat /= 0) call abort()
+ if (errstr /= "ZZZZZ") call abort()
+ if (str1 /= "abcd") call abort()
+
+ call co_broadcast(str2, source_image=num_images(), stat=stat, errmsg=errstr)
+ if (stat /= 0) call abort()
+ if (errstr /= "ZZZZZ") call abort()
+ if (any (str2 /= 4_"12 3 4 5")) call abort
+
+ call co_broadcast(dt, source_image=num_images(), stat=stat, errmsg=errstr)
+ if (stat /= 0) call abort()
+ if (errstr /= "ZZZZZ") call abort()
+ if (any (dt(:)%i /= -1)) call abort()
+ if (any (dt(:)%c /= 'a')) call abort()
+ if (any (dt(:)%x(1) /= 3.)) call abort()
+ if (any (dt(:)%x(2) /= 1.)) call abort()
+ if (any (dt(:)%x(3) /= 8.)) call abort()
+ if (any (dt(:)%y(1) /= 99.)) call abort()
+ if (any (dt(:)%y(2) /= 24.)) call abort()
+ if (any (dt(:)%y(3) /= 5.)) call abort()
+
+ sync all
+ dt = t(1, 'C', [1.,2.,3.], [3,3,3])
+ sync all
+ if (this_image() == num_images()) then
+ str2 = 4_"001122"
+ dt(2:4) = t(-2, 'i', [9.,2.,3.], [4,44,321])
+ end if
+
+ call co_broadcast(str2(::2), source_image=num_images(), stat=stat, &
+ errmsg=errstr)
+ if (stat /= 0) call abort()
+ if (errstr /= "ZZZZZ") call abort()
+ if (str2(1) /= 4_"001122") call abort()
+ if (this_image() == num_images()) then
+ if (str2(1) /= 4_"001122") call abort()
+ else
+ if (str2(2) /= 4_"12 3 4 5") call abort()
+ end if
+
+ call co_broadcast(dt(2::2), source_image=num_images(), stat=stat, &
+ errmsg=errstr)
+ if (stat /= 0) call abort()
+ if (errstr /= "ZZZZZ") call abort()
+ if (this_image() == num_images()) then
+ if (any (dt(1:1)%i /= 1)) call abort()
+ if (any (dt(1:1)%c /= 'C')) call abort()
+ if (any (dt(1:1)%x(1) /= 1.)) call abort()
+ if (any (dt(1:1)%x(2) /= 2.)) call abort()
+ if (any (dt(1:1)%x(3) /= 3.)) call abort()
+ if (any (dt(1:1)%y(1) /= 3.)) call abort()
+ if (any (dt(1:1)%y(2) /= 3.)) call abort()
+ if (any (dt(1:1)%y(3) /= 3.)) call abort()
+
+ if (any (dt(2:)%i /= -2)) call abort()
+ if (any (dt(2:)%c /= 'i')) call abort()
+ if (any (dt(2:)%x(1) /= 9.)) call abort()
+ if (any (dt(2:)%x(2) /= 2.)) call abort()
+ if (any (dt(2:)%x(3) /= 3.)) call abort()
+ if (any (dt(2:)%y(1) /= 4.)) call abort()
+ if (any (dt(2:)%y(2) /= 44.)) call abort()
+ if (any (dt(2:)%y(3) /= 321.)) call abort()
+ else
+ if (any (dt(1::2)%i /= 1)) call abort()
+ if (any (dt(1::2)%c /= 'C')) call abort()
+ if (any (dt(1::2)%x(1) /= 1.)) call abort()
+ if (any (dt(1::2)%x(2) /= 2.)) call abort()
+ if (any (dt(1::2)%x(3) /= 3.)) call abort()
+ if (any (dt(1::2)%y(1) /= 3.)) call abort()
+ if (any (dt(1::2)%y(2) /= 3.)) call abort()
+ if (any (dt(1::2)%y(3) /= 3.)) call abort()
+
+ if (any (dt(2::2)%i /= -2)) call abort()
+ if (any (dt(2::2)%c /= 'i')) call abort()
+ if (any (dt(2::2)%x(1) /= 9.)) call abort()
+ if (any (dt(2::2)%x(2) /= 2.)) call abort()
+ if (any (dt(2::2)%x(3) /= 3.)) call abort()
+ if (any (dt(2::2)%y(1) /= 4.)) call abort()
+ if (any (dt(2::2)%y(2) /= 44.)) call abort()
+ if (any (dt(2::2)%y(3) /= 321.)) call abort()
+ endif
+end program test
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fcoarray=single -std=f2008" }
+!
+!
+! CO_REDUCE/CO_BROADCAST
+!
+program test
+ implicit none
+ intrinsic co_reduce ! { dg-error "is not available in the current standard settings but new in TS 29113/TS 18508." }
+ intrinsic co_broadcast ! { dg-error "is not available in the current standard settings but new in TS 29113/TS 18508." }
+end program test
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fdump-tree-original -fcoarray=single" }
+!
+! CO_BROADCAST
+!
+program test
+ implicit none
+ intrinsic co_reduce
+ integer :: stat1
+ real :: val
+ call co_broadcast(val, source_image=1, stat=stat1)
+end program test
+
+! { dg-final { scan-tree-dump-times "stat1 = 0;" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fdump-tree-original -fcoarray=lib" }
+!
+! CO_SUM/CO_MIN/CO_MAX
+!
+program test
+ implicit none
+ intrinsic co_max
+ integer :: stat1, stat2, stat3
+ character(len=6) :: errmesg1
+ character(len=7) :: errmesg2
+ character(len=8) :: errmesg3
+ real :: val1
+ complex, allocatable :: val2(:)
+ character(len=99) :: val3
+ integer :: res
+
+ call co_broadcast(val1, source_image=num_images(), stat=stat1, errmsg=errmesg1)
+ call co_broadcast(val2, source_image=4, stat=stat2, errmsg=errmesg2)
+ call co_broadcast(val3, source_image=res,stat=stat3, errmsg=errmesg3)
+end program test
+
+! { dg-final { scan-tree-dump-times "_gfortran_caf_co_broadcast \\(&desc.., _gfortran_caf_num_images \\(0, -1\\), &stat1, errmesg1, 6\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_co_broadcast \\(&val2, 4, &stat2, errmesg2, 7\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_caf_co_broadcast \\(&desc.., res, &stat3, errmesg3, 8\\);" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+!
+! CO_BROADCAST/CO_REDUCE
+!
+program test
+ implicit none
+ intrinsic co_broadcast
+ intrinsic co_reduce
+ integer :: val, i
+ integer :: vec(3), idx(3)
+ character(len=30) :: errmsg
+ integer(8) :: i8
+ character(len=19, kind=4) :: msg4
+
+ interface
+ pure function red_f(a, b)
+ integer :: a, b, red_f
+ intent(in) :: a, b
+ end function red_f
+ impure function red_f2(a, b)
+ integer :: a, b, red_f
+ intent(in) :: a, b
+ end function red_f2
+ end interface
+
+ call co_broadcast("abc") ! { dg-error "Missing actual argument 'source_image' in call to 'co_broadcast'" }
+ call co_reduce("abc") ! { dg-error "Missing actual argument 'operator' in call to 'co_reduce'" }
+ call co_broadcast(1, source_image=1) ! { dg-error "'a' argument of 'co_broadcast' intrinsic at .1. must be a variable" }
+ call co_reduce(a=1, operator=red_f) ! { dg-error "'a' argument of 'co_reduce' intrinsic at .1. must be a variable" }
+ call co_reduce(a=val, operator=red_f2) ! { dg-error "OPERATOR argument at (1) must be a PURE function" }
+
+ call co_broadcast(val, source_image=[1,2]) ! { dg-error "must be a scalar" }
+ call co_broadcast(val, source_image=1.0) ! { dg-error "must be INTEGER" }
+ call co_broadcast(val, 1, stat=[1,2]) ! { dg-error "must be a scalar" }
+ call co_broadcast(val, 1, stat=1.0) ! { dg-error "must be INTEGER" }
+ call co_broadcast(val, 1, stat=1) ! { dg-error "must be a variable" }
+ call co_broadcast(val, stat=i, source_image=1) ! OK
+ call co_broadcast(val, stat=i, errmsg=errmsg, source_image=1) ! OK
+ call co_broadcast(val, stat=i, errmsg=[errmsg], source_image=1) ! { dg-error "must be a scalar" }
+ call co_broadcast(val, stat=i, errmsg=5, source_image=1) ! { dg-error "must be CHARACTER" }
+ call co_broadcast(val, 1, errmsg="abc") ! { dg-error "must be a variable" }
+ call co_broadcast(val, 1, stat=i8) ! { dg-error "The stat= argument at .1. must be a kind=4 integer variable" }
+ call co_broadcast(val, 1, errmsg=msg4) ! { dg-error "The errmsg= argument at .1. must be a default-kind character variable" }
+
+ call co_reduce(val, red_f, result_image=[1,2]) ! { dg-error "must be a scalar" }
+ call co_reduce(val, red_f, result_image=1.0) ! { dg-error "must be INTEGER" }
+ call co_reduce(val, red_f, stat=[1,2]) ! { dg-error "must be a scalar" }
+ call co_reduce(val, red_f, stat=1.0) ! { dg-error "must be INTEGER" }
+ call co_reduce(val, red_f, stat=1) ! { dg-error "must be a variable" }
+ call co_reduce(val, red_f, stat=i, result_image=1) ! OK
+ call co_reduce(val, red_f, stat=i, errmsg=errmsg, result_image=1) ! OK
+ call co_reduce(val, red_f, stat=i, errmsg=[errmsg], result_image=1) ! { dg-error "must be a scalar" }
+ call co_reduce(val, red_f, stat=i, errmsg=5, result_image=1) ! { dg-error "must be CHARACTER" }
+ call co_reduce(val, red_f, errmsg="abc") ! { dg-error "must be a variable" }
+ call co_reduce(val, red_f, stat=i8) ! { dg-error "The stat= argument at .1. must be a kind=4 integer variable" }
+ call co_reduce(val, red_f, errmsg=msg4) ! { dg-error "The errmsg= argument at .1. must be a default-kind character variable" }
+
+ call co_broadcasr(vec(idx), 1) ! { dg-error "Argument 'A' with INTENT\\(INOUT\\) at .1. of the intrinsic subroutine co_sum shall not have a vector subscript" }
+ call co_reduce(vec([1,3,2]), red_f) ! { dg-error "Argument 'A' with INTENT\\(INOUT\\) at .1. of the intrinsic subroutine co_min shall not have a vector subscript" }
+end program test
+2014-09-25 Tobias Burnus <burnus@net-b.de>
+
+ * caf/libcaf.h (_gfortran_caf_co_broadcast): New prototype.
+ * caf/single.c (_gfortran_caf_co_broadcast): New.
+
2014-09-18 Janne Blomqvist <jb@gcc.gnu.org>
PR libfortran/62768
__attribute__ ((noreturn));
void _gfortran_caf_error_stop (int32_t) __attribute__ ((noreturn));
-void _gfortran_caf_co_sum (gfc_descriptor_t *, int, int *,
- char *, int);
-void _gfortran_caf_co_min (gfc_descriptor_t *, int, int *, char *,
- int, int);
-void _gfortran_caf_co_max (gfc_descriptor_t *, int, int *, char *,
- int, int);
+void _gfortran_caf_co_broadcast (gfc_descriptor_t *, int, int *, char *, int);
+void _gfortran_caf_co_sum (gfc_descriptor_t *, int, int *, char *, int);
+void _gfortran_caf_co_min (gfc_descriptor_t *, int, int *, char *, int, int);
+void _gfortran_caf_co_max (gfc_descriptor_t *, int, int *, char *, int, int);
void _gfortran_caf_get (caf_token_t, size_t, int, gfc_descriptor_t *,
caf_vector_t *, gfc_descriptor_t *, int, int, bool);
}
+void
+_gfortran_caf_co_broadcast (gfc_descriptor_t *a __attribute__ ((unused)),
+ int source_image __attribute__ ((unused)),
+ int *stat, char *errmsg __attribute__ ((unused)),
+ int errmsg_len __attribute__ ((unused)))
+{
+ if (stat)
+ *stat = 0;
+}
+
void
_gfortran_caf_co_sum (gfc_descriptor_t *a __attribute__ ((unused)),
int result_image __attribute__ ((unused)),
_gfortran_caf_co_min (gfc_descriptor_t *a __attribute__ ((unused)),
int result_image __attribute__ ((unused)),
int *stat, char *errmsg __attribute__ ((unused)),
- int src_len __attribute__ ((unused)),
+ int a_len __attribute__ ((unused)),
int errmsg_len __attribute__ ((unused)))
{
if (stat)
_gfortran_caf_co_max (gfc_descriptor_t *a __attribute__ ((unused)),
int result_image __attribute__ ((unused)),
int *stat, char *errmsg __attribute__ ((unused)),
- int src_len __attribute__ ((unused)),
+ int a_len __attribute__ ((unused)),
int errmsg_len __attribute__ ((unused)))
{
if (stat)
projects / gcc.git / commitdiff