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

check.c (check_co_collective): Renamed from

Browse Source 
2014-09-25  Tobias Burnus  <burnus@net-b.de>

gcc/fortran
        * 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.

gcc/testsuite/
        * 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.

libgfortran/
        * caf/libcaf.h (_gfortran_caf_co_broadcast): New prototype.
        * caf/single.c (_gfortran_caf_co_broadcast): New.

From-SVN: r215579
This commit is contained in:
Tobias Burnus 2014-09-25 08:07:15 +02:00 committed by Tobias Burnus
parent 2bde8cac37
commit a16ee37946
18 changed files with 479 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
gcc/fortran/ChangeLog
View File

@ -1,3 +1,22 @@
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

82
gcc/fortran/check.c
View File

@ -1414,8 +1414,8 @@ gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind)
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;
@ -1424,6 +1424,7 @@ check_co_minmaxsum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
"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 "
@ -1432,21 +1433,21 @@ check_co_minmaxsum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
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)
{
@ -1458,11 +1459,11 @@ check_co_minmaxsum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
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)
{
@ -1483,6 +1484,61 @@ check_co_minmaxsum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
}
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)
@ -1496,7 +1552,7 @@ gfc_check_co_minmax (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
&a->where);
return false;
}
return check_co_minmaxsum (a, result_image, stat, errmsg);
return check_co_collective (a, result_image, stat, errmsg, false);
}
@ -1506,7 +1562,7 @@ gfc_check_co_sum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
{
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);
}

2
gcc/fortran/gfortran.h
View File

@ -369,8 +369,10 @@ enum gfc_isym_id
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,

18
gcc/fortran/intrinsic.c
View File

@ -3294,6 +3294,14 @@ add_subroutines (void)
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,
@ -3318,6 +3326,16 @@ add_subroutines (void)
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,

3
gcc/fortran/intrinsic.h
View File

@ -53,8 +53,11 @@ bool gfc_check_chdir (gfc_expr *);
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 *);

60
gcc/fortran/intrinsic.texi
View File

@ -95,6 +95,7 @@ Some basic guidelines for editing this document:
* @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
@ -3291,6 +3292,59 @@ end program test_cmplx
@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
@ -3340,7 +3394,7 @@ end program test
@end smallexample
@item @emph{See also}:
@ref{CO_MIN}, @ref{CO_SUM}
@ref{CO_MIN}, @ref{CO_SUM}, @ref{CO_BROADCAST}
@end table
@ -3394,7 +3448,7 @@ end program test
@end smallexample
@item @emph{See also}:
@ref{CO_MAX}, @ref{CO_SUM}
@ref{CO_MAX}, @ref{CO_SUM}, @ref{CO_BROADCAST}
@end table
@ -3448,7 +3502,7 @@ end program test
@end smallexample
@item @emph{See also}:
@ref{CO_MAX}, @ref{CO_MIN}
@ref{CO_MAX}, @ref{CO_MIN}, @ref{CO_BROADCAST}
@end table

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

@ -145,6 +145,7 @@ 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_co_broadcast;
tree gfor_fndecl_co_max;
tree gfor_fndecl_co_min;
tree gfor_fndecl_co_sum;
@ -3424,6 +3425,11 @@ 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_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,

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

@ -8173,7 +8173,7 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
static tree
conv_co_minmaxsum (gfc_code *code)
conv_co_collective (gfc_code *code)
{
gfc_se argse;
stmtblock_t block, post_block;
@ -8263,16 +8263,26 @@ conv_co_minmaxsum (gfc_code *code)
}
/* 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
@ -8281,7 +8291,6 @@ conv_co_minmaxsum (gfc_code *code)
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);
}
@ -8992,10 +9001,14 @@ gfc_conv_intrinsic_subroutine (gfc_code *code)
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:

1
gcc/fortran/trans.h
View File

@ -727,6 +727,7 @@ 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_co_broadcast;
extern GTY(()) tree gfor_fndecl_co_max;
extern GTY(()) tree gfor_fndecl_co_min;
extern GTY(()) tree gfor_fndecl_co_sum;

8
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,11 @@
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.

136
gcc/testsuite/gfortran.dg/coarray/collectives_3.f90 Normal file
View File

@ -0,0 +1,136 @@
! { 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

11
gcc/testsuite/gfortran.dg/coarray_collectives_10.f90 Normal file
View File

@ -0,0 +1,11 @@
! { 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

15
gcc/testsuite/gfortran.dg/coarray_collectives_11.f90 Normal file
View File

@ -0,0 +1,15 @@
! { 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" } }

26
gcc/testsuite/gfortran.dg/coarray_collectives_12.f90 Normal file
View File

@ -0,0 +1,26 @@
! { 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" } }

62
gcc/testsuite/gfortran.dg/coarray_collectives_9.f90 Normal file
View File

@ -0,0 +1,62 @@
! { 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

5
libgfortran/ChangeLog
View File

@ -1,3 +1,8 @@
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

10
libgfortran/caf/libcaf.h
View File

@ -106,12 +106,10 @@ void _gfortran_caf_error_stop_str (const char *, int32_t)
__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);

14
libgfortran/caf/single.c
View File

@ -210,6 +210,16 @@ _gfortran_caf_error_stop (int32_t error)
}
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)),
@ -224,7 +234,7 @@ void
_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)
@ -235,7 +245,7 @@ void
_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)