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

gcc/fortran/ChangeLog

+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>

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)
 {

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:");

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,

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:

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 *);

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

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
 

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 ();

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;

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

gcc/testsuite/ChangeLog

+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>
 

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

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

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

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

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() 

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

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
 
     

gcc/testsuite/gfortran.dg/coarray/collectives_1.f90

+! { 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

gcc/testsuite/gfortran.dg/coarray_collectives_1.f90

+! { 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

gcc/testsuite/gfortran.dg/coarray_collectives_2.f90

+! { 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

gcc/testsuite/gfortran.dg/coarray_collectives_3.f90

+! { 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

gcc/testsuite/gfortran.dg/coarray_collectives_4.f90

+! { 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" } }
+

gcc/testsuite/gfortran.dg/coarray_collectives_5.f90

+! { 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" } }

gcc/testsuite/gfortran.dg/coarray_collectives_6.f90

+! { 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" } }

libgfortran/ChangeLog

+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

libgfortran/caf/libcaf.h

@@ -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  */

libgfortran/caf/single.c

@@ -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;
+}