mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-09 03:00:27 +08:00
Code Issues Packages Projects Releases Wiki Activity

check.c (check_co_minmaxsum, [...]): New.

Browse Source 
gcc/fortran/
2014-05-08  Tobias Burnus  <burnus@net-b.de>

        * check.c (check_co_minmaxsum, gfc_check_co_minmax,
        gfc_check_co_sum): New.
        * error.c (gfc_notify_std): Update -std=f2008ts.
        * gfortran.h (gfc_isym_id): Add GFC_ISYM_CO_MAX,
        GFC_ISYM_CO_MIN, GFC_ISYM_CO_SUM.
        * intrinsic.h (gfc_check_co_minmax,
        gfc_check_co_sum): Declare.
        * intrinsic.c (add_subroutines): Add co_min, co_max
        and co_sum.
        (gfc_check_intrinsic_standard): Update text for
        -std=f2008ts.
        * intrinsic.texi (CO_MIN, CO_MAX, CO_SUM): Document
        them.
        * invoke.texi (-std=f2008ts): Update wording.
        * trans.h (gfor_fndecl_co_max,
        gfor_fndecl_co_min, gfor_fndecl_co_sum): Define.
        * trans-decl.c (gfor_fndecl_co_max,
        gfor_fndecl_co_min, gfor_fndecl_co_sum): Define.
        (gfc_build_builtin_function_decls): Assign to it.
        * trans-intrinsic.c (conv_co_minmaxsum): New.
        (gfc_conv_intrinsic_subroutine): Call it.

libgfortran/
2014-05-08  Tobias Burnus  <burnus@net-b.de>

        * caf/libcaf.h (caf_vector_t, _gfortran_caf_co_sum,
        _gfortran_caf_co_min, _gfortran_caf_co_max): Declare
        * caf/single.c

gcc/testsuite/
2014-05-08  Tobias Burnus  <burnus@net-b.de>

        * gfortran.dg/coarray_collectives_1.f90: New.
        * gfortran.dg/coarray_collectives_2.f90: New.
        * gfortran.dg/coarray_collectives_3.f90: New.
        * gfortran.dg/coarray_collectives_4.f90: New.
        * gfortran.dg/coarray_collectives_5.f90: New.
        * gfortran.dg/coarray_collectives_6.f90: New.
        * gfortran.dg/coarray/collectives_1.f90: New.
        * gfortran.dg/assumed_rank_5.f90: Update dg-error.
        * gfortran.dg/assumed_type_4.f90: Update dg-error.
        * gfortran.dg/bind_c_array_params.f03: Update dg-error.
        * gfortran.dg/bind_c_usage_28.f90: Update dg-error.
        * gfortran.dg/c_funloc_tests_5.f03: Update dg-error.
        * gfortran.dg/c_funloc_tests_6.f90: Update dg-error.
        * gfortran.dg/c_loc_tests_11.f03: Update dg-error.

From-SVN: r210223
This commit is contained in:
Tobias Burnus 2014-05-08 18:55:23 +02:00
parent 272325bd6a
commit d62cf3dfbe
29 changed files with 717 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
gcc/fortran/ChangeLog
View File

@ -1,3 +1,27 @@
2014-05-08 Tobias Burnus <burnus@net-b.de>
* check.c (check_co_minmaxsum, gfc_check_co_minmax,
gfc_check_co_sum): New.
* error.c (gfc_notify_std): Update -std=f2008ts.
* gfortran.h (gfc_isym_id): Add GFC_ISYM_CO_MAX,
GFC_ISYM_CO_MIN, GFC_ISYM_CO_SUM.
* intrinsic.h (gfc_check_co_minmax,
gfc_check_co_sum): Declare.
* intrinsic.c (add_subroutines): Add co_min, co_max
and co_sum.
(gfc_check_intrinsic_standard): Update text for
-std=f2008ts.
* intrinsic.texi (CO_MIN, CO_MAX, CO_SUM): Document
them.
* invoke.texi (-std=f2008ts): Update wording.
* trans.h (gfor_fndecl_co_max,
gfor_fndecl_co_min, gfor_fndecl_co_sum): Define.
* trans-decl.c (gfor_fndecl_co_max,
gfor_fndecl_co_min, gfor_fndecl_co_sum): Define.
(gfc_build_builtin_function_decls): Assign to it.
* trans-intrinsic.c (conv_co_minmaxsum): New.
(gfc_conv_intrinsic_subroutine): Call it.
2014-05-06 Kenneth Zadeck <zadeck@naturalbridge.com>
Mike Stump <mikestump@comcast.net>
Richard Sandiford <rdsandiford@googlemail.com>

85
gcc/fortran/check.c
View File

@ -1290,6 +1290,91 @@ 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)
{
if (!variable_check (a, 0, false))
return false;
if (result_image != NULL)
{
if (!type_check (result_image, 1, BT_INTEGER))
return false;
if (!scalar_check (result_image, 1))
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 (stat->ts.kind != 4)
{
gfc_error ("The stat= argument at %L must be a kind=4 integer "
"variable", &stat->where);
return false;
}
}
if (errmsg != NULL)
{
if (!type_check (errmsg, 3, BT_CHARACTER))
return false;
if (!scalar_check (errmsg, 3))
return false;
if (!variable_check (errmsg, 3, false))
return false;
if (errmsg->ts.kind != 1)
{
gfc_error ("The errmsg= argument at %L must be a default-kind "
"character variable", &errmsg->where);
return false;
}
}
if (gfc_option.coarray == GFC_FCOARRAY_NONE)
{
gfc_fatal_error ("Coarrays disabled at %L, use -fcoarray= to enable",
&a->where);
return false;
}
return true;
}
bool
gfc_check_co_minmax (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
gfc_expr *errmsg)
{
if (a->ts.type != BT_INTEGER && a->ts.type != BT_REAL
&& a->ts.type != BT_CHARACTER)
{
gfc_error ("'%s' argument of '%s' intrinsic at %L shall be of type "
"integer, real or character",
gfc_current_intrinsic_arg[0]->name, gfc_current_intrinsic,
&a->where);
return false;
}
return check_co_minmaxsum (a, result_image, stat, errmsg);
}
bool
gfc_check_co_sum (gfc_expr *a, gfc_expr *result_image, gfc_expr *stat,
gfc_expr *errmsg)
{
if (!numeric_check (a, 0))
return false;
return check_co_minmaxsum (a, result_image, stat, errmsg);
}
bool
gfc_check_complex (gfc_expr *x, gfc_expr *y)
{

2
gcc/fortran/error.c
View File

@ -878,7 +878,7 @@ gfc_notify_std (int std, const char *gmsgid, ...)
switch (std)
{
case GFC_STD_F2008_TS:
msg2 = "TS 29113:";
msg2 = "TS 29113/TS 18508:";
break;
case GFC_STD_F2008_OBS:
msg2 = _("Fortran 2008 obsolescent feature:");

3
gcc/fortran/gfortran.h
View File

@ -323,6 +323,9 @@ enum gfc_isym_id
GFC_ISYM_CHDIR,
GFC_ISYM_CHMOD,
GFC_ISYM_CMPLX,
GFC_ISYM_CO_MAX,
GFC_ISYM_CO_MIN,
GFC_ISYM_CO_SUM,
GFC_ISYM_COMMAND_ARGUMENT_COUNT,
GFC_ISYM_COMPILER_OPTIONS,
GFC_ISYM_COMPILER_VERSION,

32
gcc/fortran/intrinsic.c
View File

@ -3004,7 +3004,7 @@ add_subroutines (void)
{
/* Argument names as in the standard (to be used as argument keywords). */
const char
*h = "harvest", *dt = "date", *vl = "values", *pt = "put",
*a = "a", *h = "harvest", *dt = "date", *vl = "values", *pt = "put",
*c = "count", *tm = "time", *tp = "topos", *gt = "get",
*t = "to", *zn = "zone", *fp = "frompos", *cm = "count_max",
*f = "from", *sz = "size", *ln = "len", *cr = "count_rate",
@ -3013,7 +3013,8 @@ add_subroutines (void)
*trim_name = "trim_name", *ut = "unit", *han = "handler",
*sec = "seconds", *res = "result", *of = "offset", *md = "mode",
*whence = "whence", *pos = "pos", *ptr = "ptr", *p1 = "path1",
*p2 = "path2", *msk = "mask", *old = "old";
*p2 = "path2", *msk = "mask", *old = "old", *result_image = "result_image",
*stat = "stat", *errmsg = "errmsg";
int di, dr, dc, dl, ii;
@ -3209,6 +3210,31 @@ add_subroutines (void)
"fptr", BT_UNKNOWN, 0, REQUIRED, INTENT_OUT);
make_from_module();
/* Coarray collectives. */
add_sym_4s ("co_max", GFC_ISYM_CO_MAX, CLASS_IMPURE,
BT_UNKNOWN, 0, GFC_STD_F2008_TS,
gfc_check_co_minmax, NULL, NULL,
a, BT_REAL, dr, REQUIRED, INTENT_INOUT,
result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN,
stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT);
add_sym_4s ("co_min", GFC_ISYM_CO_MIN, CLASS_IMPURE,
BT_UNKNOWN, 0, GFC_STD_F2008_TS,
gfc_check_co_minmax, NULL, NULL,
a, BT_REAL, dr, REQUIRED, INTENT_INOUT,
result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN,
stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT);
add_sym_4s ("co_sum", GFC_ISYM_CO_SUM, CLASS_IMPURE,
BT_UNKNOWN, 0, GFC_STD_F2008_TS,
gfc_check_co_sum, NULL, NULL,
a, BT_REAL, dr, REQUIRED, INTENT_INOUT,
result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN,
stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT);
/* More G77 compatibility garbage. */
add_sym_3s ("alarm", GFC_ISYM_ALARM, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_alarm_sub, NULL, gfc_resolve_alarm_sub,
@ -4160,7 +4186,7 @@ gfc_check_intrinsic_standard (const gfc_intrinsic_sym* isym,
break;
case GFC_STD_F2008_TS:
symstd_msg = "new in TS 29113";
symstd_msg = "new in TS 29113/TS 18508";
break;
case GFC_STD_GNU:

2
gcc/fortran/intrinsic.h
View File

@ -49,6 +49,8 @@ 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_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_count (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_cshift (gfc_expr *, gfc_expr *, gfc_expr *);
bool gfc_check_ctime (gfc_expr *);

165
gcc/fortran/intrinsic.texi
View File

@ -86,6 +86,9 @@ 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_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
* @code{COMMAND_ARGUMENT_COUNT}: COMMAND_ARGUMENT_COUNT, Get number of command line arguments
* @code{COMPILER_OPTIONS}: COMPILER_OPTIONS, Options passed to the compiler
* @code{COMPILER_VERSION}: COMPILER_VERSION, Compiler version string
@ -2811,6 +2814,168 @@ end program test_cmplx
@node CO_MAX
@section @code{CO_MAX} --- Maximal value on the current set of images
@fnindex CO_MAX
@cindex Collectives, maximal value
@table @asis
@item @emph{Description}:
@code{CO_MAX} determines element-wise the maximal value of @var{A} on all
images of the current team. If @var{RESULT_IMAGE} is present, the maximum
values are returned on in @var{A} on the specified image only and the value
of @var{A} on the other images become undefined. If @var{RESULT_IMAGE} is
not present, the value is returned on all images. 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_MAX(A [, RESULT_IMAGE, STAT, ERRMSG])}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{A} @tab shall be an integer, real or character variable,
which has the same type and type parameters on all images of the team.
@item @var{RESULT_IMAGE} @tab (optional) a scalar integer expression; if
present, 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
val = this_image ()
call co_max (val, result_image=1)
if (this_image() == 1) then
write(*,*) "Maximal value", val ! prints num_images()
end if
end program test
@end smallexample
@item @emph{See also}:
@ref{CO_MIN}, @ref{CO_SUM}
@end table
@node CO_MIN
@section @code{CO_MIN} --- Minimal value on the current set of images
@fnindex CO_MIN
@cindex Collectives, minimal value
@table @asis
@item @emph{Description}:
@code{CO_MIN} determines element-wise the minimal value of @var{A} on all
images of the current team. If @var{RESULT_IMAGE} is present, the minimal
values are returned on in @var{A} on the specified image only and the value
of @var{A} on the other images become undefined. If @var{RESULT_IMAGE} is
not present, the value is returned on all images. 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_MIN(A [, RESULT_IMAGE, STAT, ERRMSG])}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{A} @tab shall be an integer, real or character variable,
which has the same type and type parameters on all images of the team.
@item @var{RESULT_IMAGE} @tab (optional) a scalar integer expression; if
present, 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
val = this_image ()
call co_min (val, result_image=1)
if (this_image() == 1) then
write(*,*) "Minimal value", val ! prints 1
end if
end program test
@end smallexample
@item @emph{See also}:
@ref{CO_MAX}, @ref{CO_SUM}
@end table
@node CO_SUM
@section @code{CO_SUM} --- Sum of values on the current set of images
@fnindex CO_SUM
@cindex Collectives, sum of values
@table @asis
@item @emph{Description}:
@code{CO_SUM} sums up the values of each element of @var{A} on all
images of the current team. If @var{RESULT_IMAGE} is present, the summed-up
values are returned on in @var{A} on the specified image only and the value
of @var{A} on the other images become undefined. If @var{RESULT_IMAGE} is
not present, the value is returned on all images. 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_MIN(A [, RESULT_IMAGE, STAT, ERRMSG])}
@item @emph{Arguments}:
@multitable @columnfractions .15 .70
@item @var{A} @tab shall be an integer, real or complex variable,
which has the same type and type parameters on all images of the team.
@item @var{RESULT_IMAGE} @tab (optional) a scalar integer expression; if
present, 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
val = this_image ()
call co_sum (val, result_image=1)
if (this_image() == 1) then
write(*,*) "The sum is ", val ! prints (n**2 + n)/2, with n = num_images()
end if
end program test
@end smallexample
@item @emph{See also}:
@ref{CO_MAX}, @ref{CO_MIN}
@end table
@node COMMAND_ARGUMENT_COUNT
@section @code{COMMAND_ARGUMENT_COUNT} --- Get number of command line arguments
@fnindex COMMAND_ARGUMENT_COUNT

2
gcc/fortran/invoke.texi
View File

@ -402,7 +402,7 @@ language standard, and warnings are given for the Fortran 77 features
that are permitted but obsolescent in later standards. @samp{-std=f2008ts}
allows the Fortran 2008 standard including the additions of the
Technical Specification (TS) 29113 on Further Interoperability of Fortran
with C.
with C and TS 18508 on Additional Parallel Features in Fortran.
@end table

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

@ -131,6 +131,9 @@ tree gfor_fndecl_caf_sync_all;
tree gfor_fndecl_caf_sync_images;
tree gfor_fndecl_caf_error_stop;
tree gfor_fndecl_caf_error_stop_str;
tree gfor_fndecl_co_max;
tree gfor_fndecl_co_min;
tree gfor_fndecl_co_sum;
/* Math functions. Many other math functions are handled in
@ -3280,12 +3283,12 @@ gfc_build_builtin_function_decls (void)
gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_sync_all")), ".WW", void_type_node,
3, pint_type, build_pointer_type (pchar_type_node), integer_type_node);
3, pint_type, pchar_type_node, integer_type_node);
gfor_fndecl_caf_sync_images = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_sync_images")), ".RRWW", void_type_node,
5, integer_type_node, pint_type, pint_type,
build_pointer_type (pchar_type_node), integer_type_node);
pchar_type_node, integer_type_node);
gfor_fndecl_caf_error_stop = gfc_build_library_function_decl (
get_identifier (PREFIX("caf_error_stop")),
@ -3298,6 +3301,21 @@ gfc_build_builtin_function_decls (void)
void_type_node, 2, pchar_type_node, gfc_int4_type_node);
/* CAF's ERROR STOP doesn't return. */
TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str) = 1;
gfor_fndecl_co_max = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_co_max")), "WR.WW",
void_type_node, 7, pvoid_type_node, pvoid_type_node, integer_type_node,
pint_type, pchar_type_node, integer_type_node, integer_type_node);
gfor_fndecl_co_min = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_co_min")), "WR.WW",
void_type_node, 7, pvoid_type_node, pvoid_type_node, integer_type_node,
pint_type, pchar_type_node, integer_type_node, integer_type_node);
gfor_fndecl_co_sum = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("caf_co_sum")), "WR.WW",
void_type_node, 6, pvoid_type_node, pvoid_type_node, integer_type_node,
pint_type, pchar_type_node, integer_type_node);
}
gfc_build_intrinsic_function_decls ();

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

@ -7508,6 +7508,124 @@ gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
}
static tree
conv_co_minmaxsum (gfc_code *code)
{
gfc_se argse;
stmtblock_t block, post_block;
tree fndecl, array, vec, strlen, image_index, stat, errmsg, errmsg_len;
gfc_start_block (&block);
gfc_init_block (&post_block);
/* stat. */
if (code->ext.actual->next->next->expr)
{
gfc_init_se (&argse, NULL);
gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
gfc_add_block_to_block (&block, &argse.pre);
gfc_add_block_to_block (&post_block, &argse.post);
stat = argse.expr;
if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
stat = gfc_build_addr_expr (NULL_TREE, stat);
}
else if (gfc_option.coarray == GFC_FCOARRAY_SINGLE)
stat = NULL_TREE;
else
stat = null_pointer_node;
/* Early exit for GFC_FCOARRAY_SINGLE. */
if (gfc_option.coarray == GFC_FCOARRAY_SINGLE)
{
if (stat != NULL_TREE)
gfc_add_modify (&block, stat,
fold_convert (TREE_TYPE (stat), integer_zero_node));
return gfc_finish_block (&block);
}
/* Handle the array. */
gfc_init_se (&argse, NULL);
if (code->ext.actual->expr->rank == 0)
{
symbol_attribute attr;
gfc_clear_attr (&attr);
gfc_init_se (&argse, NULL);
gfc_conv_expr (&argse, code->ext.actual->expr);
gfc_add_block_to_block (&block, &argse.pre);
gfc_add_block_to_block (&post_block, &argse.post);
array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
array = gfc_build_addr_expr (NULL_TREE, array);
}
else
{
argse.want_pointer = 1;
gfc_conv_expr_descriptor (&argse, code->ext.actual->expr);
array = argse.expr;
}
gfc_add_block_to_block (&block, &argse.pre);
gfc_add_block_to_block (&post_block, &argse.post);
if (code->ext.actual->expr->ts.type == BT_CHARACTER)
strlen = argse.string_length;
else
strlen = integer_zero_node;
vec = null_pointer_node;
/* image_index. */
if (code->ext.actual->next->expr)
{
gfc_init_se (&argse, NULL);
gfc_conv_expr (&argse, code->ext.actual->next->expr);
gfc_add_block_to_block (&block, &argse.pre);
gfc_add_block_to_block (&post_block, &argse.post);
image_index = fold_convert (integer_type_node, argse.expr);
}
else
image_index = integer_zero_node;
/* errmsg. */
if (code->ext.actual->next->next->next->expr)
{
gfc_init_se (&argse, NULL);
gfc_conv_expr (&argse, code->ext.actual->next->next->next->expr);
gfc_add_block_to_block (&block, &argse.pre);
gfc_add_block_to_block (&post_block, &argse.post);
errmsg = argse.expr;
errmsg_len = fold_convert (integer_type_node, argse.string_length);
}
else
{
errmsg = null_pointer_node;
errmsg_len = integer_zero_node;
}
/* 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
{
gcc_assert (code->resolved_isym->id == GFC_ISYM_CO_SUM);
fndecl = gfor_fndecl_co_sum;
}
if (code->resolved_isym->id == GFC_ISYM_CO_SUM)
fndecl = build_call_expr_loc (input_location, fndecl, 6, array, vec,
image_index, stat, errmsg, errmsg_len);
else
fndecl = build_call_expr_loc (input_location, fndecl, 7, array, vec,
image_index, stat, errmsg, strlen,
errmsg_len);
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);
}
static tree
conv_intrinsic_atomic_def (gfc_code *code)
{
@ -7803,6 +7921,11 @@ gfc_conv_intrinsic_subroutine (gfc_code *code)
res = conv_isocbinding_subroutine (code);
break;
case GFC_ISYM_CO_MIN:
case GFC_ISYM_CO_MAX:
case GFC_ISYM_CO_SUM:
res = conv_co_minmaxsum (code);
break;
default:
res = NULL_TREE;

3
gcc/fortran/trans.h
View File

@ -709,6 +709,9 @@ extern GTY(()) tree gfor_fndecl_caf_sync_all;
extern GTY(()) tree gfor_fndecl_caf_sync_images;
extern GTY(()) tree gfor_fndecl_caf_error_stop;
extern GTY(()) tree gfor_fndecl_caf_error_stop_str;
extern GTY(()) tree gfor_fndecl_co_max;
extern GTY(()) tree gfor_fndecl_co_min;
extern GTY(()) tree gfor_fndecl_co_sum;
/* Math functions. Many other math functions are handled in

27
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,20 @@
2014-05-08 Tobias Burnus <burnus@net-b.de>
* gfortran.dg/coarray_collectives_1.f90: New.
* gfortran.dg/coarray_collectives_2.f90: New.
* gfortran.dg/coarray_collectives_3.f90: New.
* gfortran.dg/coarray_collectives_4.f90: New.
* gfortran.dg/coarray_collectives_5.f90: New.
* gfortran.dg/coarray_collectives_6.f90: New.
* gfortran.dg/coarray/collectives_1.f90: New.
* gfortran.dg/assumed_rank_5.f90: Update dg-error.
* gfortran.dg/assumed_type_4.f90: Update dg-error.
* gfortran.dg/bind_c_array_params.f03: Update dg-error.
* gfortran.dg/bind_c_usage_28.f90: Update dg-error.
* gfortran.dg/c_funloc_tests_5.f03: Update dg-error.
* gfortran.dg/c_funloc_tests_6.f90: Update dg-error.
* gfortran.dg/c_loc_tests_11.f03: Update dg-error.
2014-05-08 Wei Mi <wmi@google.com>
PR target/58066
@ -564,7 +581,7 @@
2014-04-28 Martin Jambor <mjambor@suse.cz>
* gcc.dg/tree-ssa/sra-14.c: New test.
* gcc.dg/tree-ssa/sra-14.c: New test.
2014-04-28 Richard Biener <rguenther@suse.de>
@ -613,10 +630,10 @@
2014-04-25 Cary Coutant <ccoutant@google.com>
PR debug/60929
* g++.dg/debug/dwarf2/dwarf4-nested.C: New test case.
* g++.dg/debug/dwarf2/dwarf4-typedef.C: Add
-fdebug-types-section flag.
PR debug/60929
* g++.dg/debug/dwarf2/dwarf4-nested.C: New test case.
* g++.dg/debug/dwarf2/dwarf4-typedef.C: Add
-fdebug-types-section flag.
2014-04-25 Jiong Wang <jiong.wang@arm.com>

2
gcc/testsuite/gfortran.dg/assumed_rank_5.f90
View File

@ -5,5 +5,5 @@
!
!
subroutine foo(x)
integer :: x(..) ! { dg-error "TS 29113: Assumed-rank array" }
integer :: x(..) ! { dg-error "TS 29113/TS 18508: Assumed-rank array" }
end subroutine foo

2
gcc/testsuite/gfortran.dg/assumed_type_4.f90
View File

@ -6,5 +6,5 @@
! Test TYPE(*)
subroutine one(a)
type(*) :: a ! { dg-error "TS 29113: Assumed type" }
type(*) :: a ! { dg-error "TS 29113/TS 18508: Assumed type" }
end subroutine one

4
gcc/testsuite/gfortran.dg/bind_c_array_params.f03
View File

@ -5,11 +5,11 @@ use, intrinsic :: iso_c_binding
implicit none
contains
subroutine sub0(assumed_array) bind(c) ! { dg-error "TS 29113: Assumed-shape array 'assumed_array' at .1. as dummy argument to the BIND.C. procedure 'sub0'" }
subroutine sub0(assumed_array) bind(c) ! { dg-error "TS 29113/TS 18508: Assumed-shape array 'assumed_array' at .1. as dummy argument to the BIND.C. procedure 'sub0'" }
integer(c_int), dimension(:) :: assumed_array
end subroutine sub0
subroutine sub1(deferred_array) bind(c) ! { dg-error "TS 29113: Variable 'deferred_array' at .1. with POINTER attribute in procedure 'sub1' with BIND.C." }
subroutine sub1(deferred_array) bind(c) ! { dg-error "TS 29113/TS 18508: Variable 'deferred_array' at .1. with POINTER attribute in procedure 'sub1' with BIND.C." }
integer(c_int), pointer :: deferred_array(:)
end subroutine sub1
end module bind_c_array_params

4
gcc/testsuite/gfortran.dg/bind_c_usage_28.f90
View File

@ -8,11 +8,11 @@ type, bind(C) :: cstruct
integer :: i
end type
interface
subroutine psub(this) bind(c, name='Psub') ! { dg-error "TS 29113: Variable 'this' at .1. with POINTER attribute in procedure 'psub' with BIND.C." }
subroutine psub(this) bind(c, name='Psub') ! { dg-error "TS 29113/TS 18508: Variable 'this' at .1. with POINTER attribute in procedure 'psub' with BIND.C." }
import :: c_float, cstruct
real(c_float), pointer :: this(:)
end subroutine psub
subroutine psub2(that) bind(c, name='Psub2') ! { dg-error "TS 29113: Variable 'that' at .1. with ALLOCATABLE attribute in procedure 'psub2' with BIND.C." }
subroutine psub2(that) bind(c, name='Psub2') ! { dg-error "TS 29113/TS 18508: Variable 'that' at .1. with ALLOCATABLE attribute in procedure 'psub2' with BIND.C." }
import :: c_float, cstruct
type(cstruct), allocatable :: that(:)
end subroutine psub2

4
gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03
View File

@ -8,9 +8,9 @@ contains
subroutine sub0() bind(c)
type(c_funptr) :: my_c_funptr
my_c_funptr = c_funloc(sub1) ! { dg-error "TS 29113: Noninteroperable procedure at .1. to C_FUNLOC" }
my_c_funptr = c_funloc(sub1) ! { dg-error "TS 29113/TS 18508: Noninteroperable procedure at .1. to C_FUNLOC" }
my_c_funptr = c_funloc(func0) ! { dg-error "TS 29113: Noninteroperable procedure at .1. to C_FUNLOC" }
my_c_funptr = c_funloc(func0) ! { dg-error "TS 29113/TS 18508: Noninteroperable procedure at .1. to C_FUNLOC" }
end subroutine sub0
subroutine sub1()

4
gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90
View File

@ -26,6 +26,6 @@ cfp = c_loc (int) ! { dg-error "Can't convert TYPE.c_ptr. to TYPE.c_funptr." }
call c_f_pointer (cfp, int) ! { dg-error "Argument CPTR at .1. to C_F_POINTER shall have the type TYPE.C_PTR." }
call c_f_procpointer (cp, fsub) ! { dg-error "Argument CPTR at .1. to C_F_PROCPOINTER shall have the type TYPE.C_FUNPTR." }
cfp = c_funloc (noCsub) ! { dg-error "TS 29113: Noninteroperable procedure at .1. to C_FUNLOC" }
call c_f_procpointer (cfp, fint) ! { dg-error "TS 29113: Noninteroperable procedure pointer at .1. to C_F_PROCPOINTER" }
cfp = c_funloc (noCsub) ! { dg-error "TS 29113/TS 18508: Noninteroperable procedure at .1. to C_FUNLOC" }
call c_f_procpointer (cfp, fint) ! { dg-error "TS 29113/TS 18508: Noninteroperable procedure pointer at .1. to C_F_PROCPOINTER" }
end

2
gcc/testsuite/gfortran.dg/c_loc_tests_11.f03
View File

@ -43,7 +43,7 @@ contains
integer(c_int), intent(in) :: handle
get_foo_address = c_loc(foo_pool(handle)%v)
get_foo_address = c_loc(foo_pool2(handle)%v) ! { dg-error "TS 29113: Noninteroperable array at .1. as argument to C_LOC: Expression is a noninteroperable derived type" }
get_foo_address = c_loc(foo_pool2(handle)%v) ! { dg-error "TS 29113/TS 18508: Noninteroperable array at .1. as argument to C_LOC: Expression is a noninteroperable derived type" }
end function get_foo_address

44
gcc/testsuite/gfortran.dg/coarray/collectives_1.f90 Normal file
View File

@ -0,0 +1,44 @@
! { dg-do run }
!
! CO_SUM/CO_MIN/CO_MAX
!
program test
implicit none
intrinsic co_max
intrinsic co_min
intrinsic co_sum
call test_min
call test_max
call test_sum
contains
subroutine test_min
integer :: val
val = this_image ()
call co_max (val, result_image=1)
if (this_image() == 1) then
!write(*,*) "Maximal value", val
if (val /= num_images()) call abort()
end if
end subroutine test_min
subroutine test_max
integer :: val
val = this_image ()
call co_min (val, result_image=1)
if (this_image() == 1) then
!write(*,*) "Minimal value", val
if (val /= 1) call abort()
end if
end subroutine test_max
subroutine test_sum
integer :: val, n
val = this_image ()
call co_sum (val, result_image=1)
if (this_image() == 1) then
!write(*,*) "The sum is ", val
n = num_images()
if (val /= (n**2 + n)/2) call abort()
end if
end subroutine test_sum
end program test

38
gcc/testsuite/gfortran.dg/coarray_collectives_1.f90 Normal file
View File

@ -0,0 +1,38 @@
! { dg-do compile }
! { dg-options "-fcoarray=single" }
!
!
! CO_SUM/CO_MIN/CO_MAX
!
program test
implicit none
intrinsic co_max
intrinsic co_min
intrinsic co_sum
integer :: val, i
character(len=30) :: errmsg
integer(8) :: i8
character(len=19, kind=4) :: msg4
call co_sum("abc") ! { dg-error "must be a numeric type" }
call co_max(cmplx(1.0,0.0)) ! { dg-error "shall be of type integer, real or character" }
call co_min(cmplx(0.0,1.0)) ! { dg-error "shall be of type integer, real or character" }
call co_sum(1) ! { dg-error "must be a variable" }
call co_min("abc") ! { dg-error "must be a variable" }
call co_max(2.3) ! { dg-error "must be a variable" }
call co_sum(val, result_image=[1,2]) ! { dg-error "must be a scalar" }
call co_sum(val, result_image=1.0) ! { dg-error "must be INTEGER" }
call co_min(val, stat=[1,2]) ! { dg-error "must be a scalar" }
call co_min(val, stat=1.0) ! { dg-error "must be INTEGER" }
call co_min(val, stat=1) ! { dg-error "must be a variable" }
call co_min(val, stat=i, result_image=1) ! OK
call co_max(val, stat=i, errmsg=errmsg, result_image=1) ! OK
call co_max(val, stat=i, errmsg=[errmsg], result_image=1) ! { dg-error "must be a scalar" }
call co_max(val, stat=i, errmsg=5, result_image=1) ! { dg-error "must be CHARACTER" }
call co_sum(val, errmsg="abc") ! { dg-error "must be a variable" }
call co_sum(val, stat=i8) ! { dg-error "The stat= argument at .1. must be a kind=4 integer variable" }
call co_min(val, errmsg=msg4) ! { dg-error "The errmsg= argument at .1. must be a default-kind character variable" }
end program test

12
gcc/testsuite/gfortran.dg/coarray_collectives_2.f90 Normal file
View File

@ -0,0 +1,12 @@
! { dg-do compile }
! { dg-options "-fcoarray=single -std=f2008" }
!
!
! CO_SUM/CO_MIN/CO_MAX
!
program test
implicit none
intrinsic co_max ! { dg-error "is not available in the current standard settings but new in TS 29113/TS 18508." }
intrinsic co_min ! { dg-error "is not available in the current standard settings but new in TS 29113/TS 18508." }
intrinsic co_sum ! { dg-error "is not available in the current standard settings but new in TS 29113/TS 18508." }
end program test

10
gcc/testsuite/gfortran.dg/coarray_collectives_3.f90 Normal file
View File

@ -0,0 +1,10 @@
! { dg-do compile }
!
! CO_SUM/CO_MIN/CO_MAX
!
program test
implicit none
intrinsic co_max
integer :: val
call co_max(val) ! { dg-error "Coarrays disabled at .1., use -fcoarray= to enable" }
end program test

20
gcc/testsuite/gfortran.dg/coarray_collectives_4.f90 Normal file
View File

@ -0,0 +1,20 @@
! { dg-do compile }
! { dg-options "-fdump-tree-original -fcoarray=single" }
!
! CO_SUM/CO_MIN/CO_MAX
!
program test
implicit none
intrinsic co_max
integer :: stat1, stat2, stat3
real :: val
call co_max(val, stat=stat1)
call co_min(val, stat=stat2)
call co_sum(val, stat=stat3)
end program test
! { dg-final { scan-tree-dump-times "stat1 = 0;" 1 "original" } }
! { dg-final { scan-tree-dump-times "stat2 = 0;" 1 "original" } }
! { dg-final { scan-tree-dump-times "stat3 = 0;" 1 "original" } }
! { dg-final { cleanup-tree-dump "original" } }

19
gcc/testsuite/gfortran.dg/coarray_collectives_5.f90 Normal file
View File

@ -0,0 +1,19 @@
! { 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
real :: val
call co_max(val, stat=stat1)
call co_min(val, stat=stat2)
call co_sum(val, stat=stat3)
end program test
! { dg-final { scan-tree-dump-times "_gfortran_caf_co_max \\(&desc.., 0B, 0, &stat1, 0B, 0, 0\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_co_min \\(&desc.., 0B, 0, &stat2, 0B, 0, 0\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_co_sum \\(&desc.., 0B, 0, &stat3, 0B, 0\\);" 1 "original" } }
! { dg-final { cleanup-tree-dump "original" } }

26
gcc/testsuite/gfortran.dg/coarray_collectives_6.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_max(val1, stat=stat1, errmsg=errmesg1)
call co_sum(val2, result_image=4, stat=stat2, errmsg=errmesg2)
call co_min(val3, result_image=res,stat=stat3, errmsg=errmesg3)
end program test
! { dg-final { scan-tree-dump-times "_gfortran_caf_co_max \\(&desc.., 0B, 0, &stat1, errmesg1, 0, 6\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_co_sum \\(&val2, 0B, 4, &stat2, errmesg2, 7\\);" 1 "original" } }
! { dg-final { scan-tree-dump-times "_gfortran_caf_co_min \\(&desc.., 0B, res, &stat3, errmesg3, 99, 8\\);" 1 "original" } }
! { dg-final { cleanup-tree-dump "original" } }

6
libgfortran/ChangeLog
View File

@ -1,3 +1,9 @@
2014-05-08 Tobias Burnus <burnus@net-b.de>
* caf/libcaf.h (caf_vector_t, _gfortran_caf_co_sum,
_gfortran_caf_co_min, _gfortran_caf_co_max): Declare
* caf/single.c
2014-05-06 Jerry DeLisle <jvdelisle@gcc.gnu>
PR libfortran/61049

17
libgfortran/caf/libcaf.h
View File

@ -65,6 +65,17 @@ typedef struct caf_static_t {
}
caf_static_t;
typedef struct caf_vector_t {
size_t nvec; /* size of the vector; 0 means dim triplet. */
union {
struct {
ptrdiff_t lower_bound, upper_bound, stride;
} triplet;
ptrdiff_t *vector;
} u;
}
caf_vector_t;
void _gfortran_caf_init (int *, char ***);
void _gfortran_caf_finalize (void);
@ -92,4 +103,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 (void *, caf_vector_t *, int, int *, char *, int);
void _gfortran_caf_co_min (void *, caf_vector_t *, int, int *, char *, int,
int);
void _gfortran_caf_co_max (void *, caf_vector_t *, int, int *, char *, int,
int);
#endif /* LIBCAF_H */

36
libgfortran/caf/single.c
View File

@ -202,3 +202,39 @@ _gfortran_caf_error_stop (int32_t error)
fprintf (stderr, "ERROR STOP %d\n", error);
exit (error);
}
void
_gfortran_caf_co_sum (void *a __attribute__ ((unused)),
caf_vector_t vector[] __attribute__ ((unused)),
int result_image __attribute__ ((unused)),
int *stat, char *errmsg __attribute__ ((unused)),
int errmsg_len __attribute__ ((unused)))
{
if (stat)
stat = 0;
}
void
_gfortran_caf_co_min (void *a __attribute__ ((unused)),
caf_vector_t vector[] __attribute__ ((unused)),
int result_image __attribute__ ((unused)),
int *stat, char *errmsg __attribute__ ((unused)),
int src_len __attribute__ ((unused)),
int errmsg_len __attribute__ ((unused)))
{
if (stat)
stat = 0;
}
void
_gfortran_caf_co_max (void *a __attribute__ ((unused)),
caf_vector_t vector[] __attribute__ ((unused)),
int result_image __attribute__ ((unused)),
int *stat, char *errmsg __attribute__ ((unused)),
int src_len __attribute__ ((unused)),
int errmsg_len __attribute__ ((unused)))
{
if (stat)
stat = 0;
}