diff options
author | Tobias Burnus <burnus@gcc.gnu.org> | 2014-05-08 18:55:23 +0200 |
---|---|---|
committer | Tobias Burnus <burnus@gcc.gnu.org> | 2014-05-08 18:55:23 +0200 |
commit | d62cf3dfbe72b168d9bde08b34e2a190cdf7eb33 (patch) | |
tree | 778c1f6a41dea0e8e0d26817d32358e245d22ded /gcc | |
parent | 272325bd6abba598a8f125dab36b626acb648b03 (diff) | |
download | gcc-d62cf3dfbe72b168d9bde08b34e2a190cdf7eb33.zip gcc-d62cf3dfbe72b168d9bde08b34e2a190cdf7eb33.tar.gz gcc-d62cf3dfbe72b168d9bde08b34e2a190cdf7eb33.tar.bz2 |
check.c (check_co_minmaxsum, [...]): New.
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
Diffstat (limited to 'gcc')
26 files changed, 658 insertions, 23 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 5e39b13..07a84d4 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -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> diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index b83d9da..90ba0c9 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -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) { diff --git a/gcc/fortran/error.c b/gcc/fortran/error.c index e843fa5..6ae44e8 100644 --- a/gcc/fortran/error.c +++ b/gcc/fortran/error.c @@ -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:"); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 0707b58..63be8af 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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, diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 19d4620..852ae92 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -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: diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index d7f7954..162fa71 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -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 *); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 926ffe9..b091ee4 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -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 diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi index b92abfc..4c7d4a3 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -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 diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index bd1ebab..5dd5d2a 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -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 (); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index c166c4f..755d3d4 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -7509,6 +7509,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) { gfc_se atom, value; @@ -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; diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 13b0a00..baae780 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -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 diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index f5132d8..7ea4d9e 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -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> diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_5.f90 b/gcc/testsuite/gfortran.dg/assumed_rank_5.f90 index a794996..f3d633d 100644 --- a/gcc/testsuite/gfortran.dg/assumed_rank_5.f90 +++ b/gcc/testsuite/gfortran.dg/assumed_rank_5.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/assumed_type_4.f90 b/gcc/testsuite/gfortran.dg/assumed_type_4.f90 index 1ea982e..e940c45 100644 --- a/gcc/testsuite/gfortran.dg/assumed_type_4.f90 +++ b/gcc/testsuite/gfortran.dg/assumed_type_4.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/bind_c_array_params.f03 b/gcc/testsuite/gfortran.dg/bind_c_array_params.f03 index 0e9903c..1604517 100644 --- a/gcc/testsuite/gfortran.dg/bind_c_array_params.f03 +++ b/gcc/testsuite/gfortran.dg/bind_c_array_params.f03 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/bind_c_usage_28.f90 b/gcc/testsuite/gfortran.dg/bind_c_usage_28.f90 index ff03ef4..bb9b5e8 100644 --- a/gcc/testsuite/gfortran.dg/bind_c_usage_28.f90 +++ b/gcc/testsuite/gfortran.dg/bind_c_usage_28.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03 b/gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03 index ae321a9..8c1843b 100644 --- a/gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03 +++ b/gcc/testsuite/gfortran.dg/c_funloc_tests_5.f03 @@ -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() diff --git a/gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90 b/gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90 index 1a7f036..d426e81 100644 --- a/gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90 +++ b/gcc/testsuite/gfortran.dg/c_funloc_tests_6.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/c_loc_tests_11.f03 b/gcc/testsuite/gfortran.dg/c_loc_tests_11.f03 index c00e5ed..d009ce0 100644 --- a/gcc/testsuite/gfortran.dg/c_loc_tests_11.f03 +++ b/gcc/testsuite/gfortran.dg/c_loc_tests_11.f03 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray/collectives_1.f90 b/gcc/testsuite/gfortran.dg/coarray/collectives_1.f90 new file mode 100644 index 0000000..1404938 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray/collectives_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_1.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_1.f90 new file mode 100644 index 0000000..a09a81f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_collectives_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_2.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_2.f90 new file mode 100644 index 0000000..7494d3d4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_collectives_2.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_3.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_3.f90 new file mode 100644 index 0000000..971ee6a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_collectives_3.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_4.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_4.f90 new file mode 100644 index 0000000..8b3da94 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_collectives_4.f90 @@ -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" } } + diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_5.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_5.f90 new file mode 100644 index 0000000..15894d2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_collectives_5.f90 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_6.f90 b/gcc/testsuite/gfortran.dg/coarray_collectives_6.f90 new file mode 100644 index 0000000..630ce9d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_collectives_6.f90 @@ -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" } } |