check.c (gfc_check_num_images): New.

2014-05-25  Tobias Burnus  <burnus@net-b.de>

        * check.c (gfc_check_num_images): New.
        (gfc_check_this_image): Handle distance argument.
        * intrinsic.c (add_functions): Update this_image and num_images
        for new distance and failed arguments.
        * intrinsic.texi (THIS_IMAGE, NUM_IMAGES): Document the new
        arguments.
        * intrinsic.h (gfc_check_num_images): New.
        (gfc_check_this_image, gfc_simplify_num_images,
        gfc_simplify_this_image, gfc_resolve_this_image): Update prototype.
        * iresolve.c (gfc_resolve_this_image): Handle distance argument.
        * simplify.c (gfc_simplify_num_images, gfc_simplify_this_image):
        Handle new arguments.
        * trans-intrinsic.c (trans_this_image, trans_num_images): Ditto.
        (gfc_conv_intrinsic_function): Update trans_num_images call.

2014-05-25  Tobias Burnus  <burnus@net-b.de>

        * gfortran.dg/coarray_10.f90: Update dg-warning.
        * gfortran.dg/coarray_this_image_1.f90: New.
        * gfortran.dg/coarray_this_image_2.f90: New.

From-SVN: r210909

gcc/fortran/ChangeLog

+2014-05-25  Tobias Burnus  <burnus@net-b.de>
+
+	* check.c (gfc_check_num_images): New.
+	(gfc_check_this_image): Handle distance argument.
+	* intrinsic.c (add_functions): Update this_image and num_images
+	for new distance and failed arguments.
+	* intrinsic.texi (THIS_IMAGE, NUM_IMAGES): Document the new
+	arguments.
+	* intrinsic.h (gfc_check_num_images): New.
+	(gfc_check_this_image, gfc_simplify_num_images,
+	gfc_simplify_this_image, gfc_resolve_this_image): Update prototype.
+	* iresolve.c (gfc_resolve_this_image): Handle distance argument.
+	* simplify.c (gfc_simplify_num_images, gfc_simplify_this_image):
+	Handle new arguments.
+	* trans-intrinsic.c (trans_this_image, trans_num_images): Ditto.
+	(gfc_conv_intrinsic_function): Update trans_num_images call.
+
 2014-05-23  Tobias Burnus  <burnus@net-b.de>
 
 	* gfc-internals.texi: Change URLs to HTTPS; fix broken links.

gcc/fortran/check.c

@@ -4552,7 +4552,7 @@ gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub)
 
 
 bool
-gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim)
+gfc_check_num_images (gfc_expr *distance, gfc_expr *failed)
 {
   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
     {
@@ -4560,16 +4560,96 @@ gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim)
       return false;
     }
 
-  if (dim != NULL &&  coarray == NULL)
+  if (distance)
     {
-      gfc_error ("DIM argument without ARRAY argument not allowed for THIS_IMAGE "
-                "intrinsic at %L", &dim->where);
+      if (!type_check (distance, 0, BT_INTEGER))
+	return false;
+
+      if (!nonnegative_check ("DISTANCE", distance))
+	return false;
+
+      if (!scalar_check (distance, 0))
+	return false;
+
+      if (!gfc_notify_std (GFC_STD_F2008_TS, "DISTANCE= argument to "
+			   "NUM_IMAGES at %L", &distance->where))
+	return false;
+    }
+
+   if (failed)
+    {
+      if (!type_check (failed, 1, BT_LOGICAL))
+	return false;
+
+      if (!scalar_check (failed, 1))
+	return false;
+
+      if (!gfc_notify_std (GFC_STD_F2008_TS, "FAILED= argument to "
+			   "NUM_IMAGES at %L", &distance->where))
+	return false;
+    }
+
+  return true;
+}
+
+
+bool
+gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim, gfc_expr *distance)
+{
+  if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+    {
+      gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
       return false;
     }
 
-  if (coarray == NULL)
+  if (coarray == NULL && dim == NULL && distance == NULL)
     return true;
 
+  if (dim != NULL && coarray == NULL)
+    {
+      gfc_error ("DIM argument without COARRAY argument not allowed for "
+		 "THIS_IMAGE intrinsic at %L", &dim->where);
+      return false;
+    }
+
+  if (distance && (coarray || dim))
+    {
+      gfc_error ("The DISTANCE argument may not be specified together with the "
+		 "COARRAY or DIM argument in intrinsic at %L",
+		 &distance->where);
+      return false;
+    }
+
+  /* Assume that we have "this_image (distance)".  */
+  if (coarray && !gfc_is_coarray (coarray) && coarray->ts.type == BT_INTEGER)
+    {
+      if (dim)
+	{
+	  gfc_error ("Unexpected DIM argument with noncoarray argument at %L",
+		     &coarray->where);
+	  return false;
+	}
+      distance = coarray;
+    }
+
+  if (distance)
+    {
+      if (!type_check (distance, 2, BT_INTEGER))
+	return false;
+
+      if (!nonnegative_check ("DISTANCE", distance))
+	return false;
+
+      if (!scalar_check (distance, 2))
+	return false;
+
+      if (!gfc_notify_std (GFC_STD_F2008_TS, "DISTANCE= argument to "
+			   "THIS_IMAGE at %L", &distance->where))
+	return false;
+
+      return true;
+    }
+
   if (!coarray_check (coarray, 0))
     return false;
 

gcc/fortran/intrinsic.c

@@ -1205,7 +1205,7 @@ add_functions (void)
     *z = "z", *ln = "len", *ut = "unit", *han = "handler",
     *num = "number", *tm = "time", *nm = "name", *md = "mode",
     *vl = "values", *p1 = "path1", *p2 = "path2", *com = "command",
-    *ca = "coarray", *sub = "sub";
+    *ca = "coarray", *sub = "sub", *dist = "distance", *failed="failed";
 
   int di, dr, dd, dl, dc, dz, ii;
 
@@ -2477,9 +2477,11 @@ add_functions (void)
 
   make_generic ("null", GFC_ISYM_NULL, GFC_STD_F95);
 
-  add_sym_0 ("num_images", GFC_ISYM_NUM_IMAGES, CLASS_INQUIRY, ACTUAL_NO,
+  add_sym_2 ("num_images", GFC_ISYM_NUM_IMAGES, CLASS_INQUIRY, ACTUAL_NO,
 	     BT_INTEGER, di, GFC_STD_F2008,
-	     NULL, gfc_simplify_num_images, NULL);
+	     gfc_check_num_images, gfc_simplify_num_images, NULL,
+	     dist, BT_INTEGER, di, OPTIONAL,
+	     failed, BT_LOGICAL, dl, OPTIONAL);
 
   add_sym_3 ("pack", GFC_ISYM_PACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
 	     gfc_check_pack, gfc_simplify_pack, gfc_resolve_pack,
@@ -2892,9 +2894,10 @@ add_functions (void)
 
   make_generic ("tanh", GFC_ISYM_TANH, GFC_STD_F77);
 
-  add_sym_2 ("this_image", GFC_ISYM_THIS_IMAGE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008,
+  add_sym_3 ("this_image", GFC_ISYM_THIS_IMAGE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008,
 	     gfc_check_this_image, gfc_simplify_this_image, gfc_resolve_this_image,
-	     ca, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL);
+	     ca, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL,
+	     dist, BT_INTEGER, di, OPTIONAL);
 
   add_sym_0 ("time", GFC_ISYM_TIME, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
 	     di, GFC_STD_GNU, NULL, NULL, gfc_resolve_time);

gcc/fortran/intrinsic.h

@@ -117,6 +117,7 @@ bool gfc_check_nearest (gfc_expr *, gfc_expr *);
 bool gfc_check_new_line (gfc_expr *);
 bool gfc_check_norm2 (gfc_expr *, gfc_expr *);
 bool gfc_check_null (gfc_expr *);
+bool gfc_check_num_images (gfc_expr *, gfc_expr *);
 bool gfc_check_pack (gfc_expr *, gfc_expr *, gfc_expr *);
 bool gfc_check_parity (gfc_expr *, gfc_expr *);
 bool gfc_check_precision (gfc_expr *);
@@ -212,7 +213,7 @@ bool gfc_check_signal_sub (gfc_expr *, gfc_expr *, gfc_expr *);
 bool gfc_check_sleep_sub (gfc_expr *);
 bool gfc_check_stat_sub (gfc_expr *, gfc_expr *, gfc_expr *);
 bool gfc_check_system_sub (gfc_expr *, gfc_expr *);
-bool gfc_check_this_image (gfc_expr *, gfc_expr *);
+bool gfc_check_this_image (gfc_expr *, gfc_expr *, gfc_expr *);
 bool gfc_check_ttynam_sub (gfc_expr *, gfc_expr *);
 bool gfc_check_umask_sub (gfc_expr *, gfc_expr *);
 bool gfc_check_unlink_sub (gfc_expr *, gfc_expr *);
@@ -343,7 +344,7 @@ gfc_expr *gfc_simplify_new_line (gfc_expr *);
 gfc_expr *gfc_simplify_nint (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_norm2 (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_null (gfc_expr *);
-gfc_expr *gfc_simplify_num_images (void);
+gfc_expr *gfc_simplify_num_images (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_idnint (gfc_expr *);
 gfc_expr *gfc_simplify_not (gfc_expr *);
 gfc_expr *gfc_simplify_or (gfc_expr *, gfc_expr *);
@@ -387,7 +388,7 @@ gfc_expr *gfc_simplify_sqrt (gfc_expr *);
 gfc_expr *gfc_simplify_sum (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_tan (gfc_expr *);
 gfc_expr *gfc_simplify_tanh (gfc_expr *);
-gfc_expr *gfc_simplify_this_image (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_this_image (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_tiny (gfc_expr *);
 gfc_expr *gfc_simplify_trailz (gfc_expr *);
 gfc_expr *gfc_simplify_transfer (gfc_expr *, gfc_expr *, gfc_expr *);
@@ -568,7 +569,7 @@ void gfc_resolve_symlnk (gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_system (gfc_expr *, gfc_expr *);
 void gfc_resolve_tan (gfc_expr *, gfc_expr *);
 void gfc_resolve_tanh (gfc_expr *, gfc_expr *);
-void gfc_resolve_this_image (gfc_expr *, gfc_expr *, gfc_expr *);
+void gfc_resolve_this_image (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 void gfc_resolve_time (gfc_expr *);
 void gfc_resolve_time8 (gfc_expr *);
 void gfc_resolve_transfer (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);

gcc/fortran/intrinsic.texi

@@ -9676,18 +9676,32 @@ REAL, POINTER, DIMENSION(:) :: VEC => NULL ()
 Returns the number of images.
 
 @item @emph{Standard}:
-Fortran 2008 and later
+Fortran 2008 and later. With @var{DISTANCE} or @var{FAILED} argument, 
+Technical Specification (TS) 18508 or later
+
 
 @item @emph{Class}:
 Transformational function
 
 @item @emph{Syntax}:
-@code{RESULT = NUM_IMAGES()}
+@code{RESULT = NUM_IMAGES(DISTANCE, FAILED)}
 
-@item @emph{Arguments}: None.
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{DISTANCE} @tab (optional, intent(in)) Nonnegative scalar integer
+@item @var{FAILED}   @tab (optional, intent(in)) Scalar logical expression
+@end multitable
 
 @item @emph{Return value}:
-Scalar default-kind integer.
+Scalar default-kind integer.  If @var{DISTANCE} is not present or has value 0,
+the number of images in the current team is returned. For values smaller or
+equal distance to the initial team, it returns the number of images index
+on the ancestor team which has a distance of @var{DISTANCE} from the invoking
+team. If @var{DISTANCE} is larger than the distance to the initial team, the
+number of images of the initial team is returned. If @var{FAILED} is not present
+the total number of images is returned; if it has the value @code{.TRUE.},
+the number of failed images is returned, otherwise, the number of images which
+do have not the failed status.
 
 @item @emph{Example}:
 @smallexample
@@ -12422,7 +12436,8 @@ end program test_tanh
 Returns the cosubscript for this image.
 
 @item @emph{Standard}:
-Fortran 2008 and later
+Fortran 2008 and later. With @var{DISTANCE} argument, 
+Technical Specification (TS) 18508 or later
 
 @item @emph{Class}:
 Transformational function
@@ -12430,11 +12445,14 @@ Transformational function
 @item @emph{Syntax}:
 @multitable @columnfractions .80
 @item @code{RESULT = THIS_IMAGE()}
+@item @code{RESULT = THIS_IMAGE(DISTANCE)}
 @item @code{RESULT = THIS_IMAGE(COARRAY [, DIM])}
 @end multitable
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
+@item @var{DISTANCE} @tab (optional, intent(in)) Nonnegative scalar integer
+(not permitted together with @var{COARRAY}).
 @item @var{COARRAY} @tab Coarray of any type  (optional; if @var{DIM}
 present, required).
 @item @var{DIM}     @tab default integer scalar (optional). If present,
@@ -12443,12 +12461,17 @@ present, required).
 
 
 @item @emph{Return value}:
-Default integer. If @var{COARRAY} is not present, it is scalar and its value
-is the index of the invoking image. Otherwise, if @var{DIM} is not present,
-a rank-1 array with corank elements is returned, containing the cosubscripts
-for @var{COARRAY} specifying the invoking image. If @var{DIM} is present,
-a scalar is returned, with the value of the @var{DIM} element of
-@code{THIS_IMAGE(COARRAY)}.
+Default integer. If @var{COARRAY} is not present, it is scalar; if
+@var{DISTANCE} is not present or has value 0, its value is the image index on
+the invoking image for the current team, for values smaller or equal
+distance to the initial team, it returns the image index on the ancestor team
+which has a distance of @var{DISTANCE} from the invoking team. If
+@var{DISTANCE} is larger than the distance to the initial team, the image
+index of the initial team is returned. Otherwise when the @var{COARRAY} is
+present, if @var{DIM} is not present, a rank-1 array with corank elements is
+returned, containing the cosubscripts for @var{COARRAY} specifying the invoking
+image. If @var{DIM} is present, a scalar is returned, with the value of
+the @var{DIM} element of @code{THIS_IMAGE(COARRAY)}.
 
 @item @emph{Example}:
 @smallexample
@@ -12461,6 +12484,10 @@ IF (THIS_IMAGE() == 1) THEN
     WRITE(*,'(2(a,i0))') 'value[', i, '] is ', value[i]
   END DO
 END IF
+
+! Check whether the current image is the initial image
+IF (THIS_IMAGE(HUGE(1)) /= THIS_IMAGE())
+  error stop "something is rotten here"
 @end smallexample
 
 @item @emph{See also}:

gcc/fortran/iresolve.c

@@ -2590,10 +2590,11 @@ gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
 
 
 void
-gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
+gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
+			gfc_expr *distance ATTRIBUTE_UNUSED)
 {
   static char this_image[] = "__this_image";
-  if (array)
+  if (array && gfc_is_coarray (array))
     resolve_bound (f, array, dim, NULL, "__this_image", true);
   else
     {

gcc/fortran/simplify.c

@@ -4601,7 +4601,7 @@ gfc_simplify_null (gfc_expr *mold)
 
 
 gfc_expr *
-gfc_simplify_num_images (void)
+gfc_simplify_num_images (gfc_expr *distance ATTRIBUTE_UNUSED, gfc_expr *failed)
 {
   gfc_expr *result;
 
@@ -4614,10 +4614,18 @@ gfc_simplify_num_images (void)
   if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
     return NULL;
 
+  if (failed && failed->expr_type != EXPR_CONSTANT)
+    return NULL;
+
   /* FIXME: gfc_current_locus is wrong.  */
   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
 				  &gfc_current_locus);
-  mpz_set_si (result->value.integer, 1);
+
+  if (failed && failed->value.logical != 0)
+    mpz_set_si (result->value.integer, 0);
+  else
+    mpz_set_si (result->value.integer, 1);
+
   return result;
 }
 
@@ -6389,12 +6397,15 @@ gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
 
 
 gfc_expr *
-gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
+gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim,
+			 gfc_expr *distance ATTRIBUTE_UNUSED)
 {
   if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
     return NULL;
 
-  if (coarray == NULL)
+  /* If no coarray argument has been passed or when the first argument
+     is actually a distance argment.  */
+  if (coarray == NULL || !gfc_is_coarray (coarray))
     {
       gfc_expr *result;
       /* FIXME: gfc_current_locus is wrong.  */

gcc/fortran/trans-intrinsic.c

@@ -934,15 +934,30 @@ trans_this_image (gfc_se * se, gfc_expr *expr)
        lbound, ubound, extent, ml;
   gfc_se argse;
   int rank, corank;
+  gfc_expr *distance = expr->value.function.actual->next->next->expr;
+
+  if (expr->value.function.actual->expr
+      && !gfc_is_coarray (expr->value.function.actual->expr))
+    distance = expr->value.function.actual->expr;
 
   /* The case -fcoarray=single is handled elsewhere.  */
   gcc_assert (gfc_option.coarray != GFC_FCOARRAY_SINGLE);
 
   /* Argument-free version: THIS_IMAGE().  */
-  if (expr->value.function.actual->expr == NULL)
+  if (distance || expr->value.function.actual->expr == NULL)
     {
+      if (distance)
+	{
+	  gfc_init_se (&argse, NULL);
+	  gfc_conv_expr_val (&argse, distance);
+	  gfc_add_block_to_block (&se->pre, &argse.pre);
+	  gfc_add_block_to_block (&se->post, &argse.post);
+	  tmp = fold_convert (integer_type_node, argse.expr);
+	}
+      else
+	tmp = integer_zero_node;
       tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
-				 integer_zero_node);
+				 tmp);
       se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
 			       tmp);
       return;
@@ -1262,11 +1277,35 @@ trans_image_index (gfc_se * se, gfc_expr *expr)
 
 
 static void
-trans_num_images (gfc_se * se)
+trans_num_images (gfc_se * se, gfc_expr *expr)
 {
-  tree tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
-				  integer_zero_node,
-				  build_int_cst (integer_type_node, -1));
+  tree tmp, distance, failed;
+  gfc_se argse;
+
+  if (expr->value.function.actual->expr)
+    {
+      gfc_init_se (&argse, NULL);
+      gfc_conv_expr_val (&argse, expr->value.function.actual->expr);
+      gfc_add_block_to_block (&se->pre, &argse.pre);
+      gfc_add_block_to_block (&se->post, &argse.post);
+      distance = fold_convert (integer_type_node, argse.expr);
+    }
+  else
+    distance = integer_zero_node;
+
+  if (expr->value.function.actual->next->expr)
+    {
+      gfc_init_se (&argse, NULL);
+      gfc_conv_expr_val (&argse, expr->value.function.actual->next->expr);
+      gfc_add_block_to_block (&se->pre, &argse.pre);
+      gfc_add_block_to_block (&se->post, &argse.post);
+      failed = fold_convert (integer_type_node, argse.expr);
+    }
+  else
+    failed = build_int_cst (integer_type_node, -1);
+
+  tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
+			     distance, failed);
   se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
 }
 
@@ -7099,7 +7138,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
       break;
 
     case GFC_ISYM_NUM_IMAGES:
-      trans_num_images (se);
+      trans_num_images (se, expr);
       break;
 
     case GFC_ISYM_ACCESS:

gcc/testsuite/ChangeLog

+2014-05-25  Tobias Burnus  <burnus@net-b.de>
+
+	* gfortran.dg/coarray_10.f90: Update dg-warning.
+	* gfortran.dg/coarray_this_image_1.f90: New.
+	* gfortran.dg/coarray_this_image_2.f90: New.
+
 2014-05-24  Jerry DeLisle  <jvdelisle@gcc.gnu>
 
 	PR libfortran/61173

gcc/testsuite/gfortran.dg/coarray_10.f90

@@ -21,7 +21,7 @@ subroutine this_image_check()
   integer,save :: z(4)[*], i
 
   j = this_image(a,dim=3) ! { dg-error "not a valid codimension index" }
-  j = this_image(dim=3) ! { dg-error "DIM argument without ARRAY argument" }
+  j = this_image(dim=3) ! { dg-error "DIM argument without COARRAY argument" }
   i = image_index(i, [ 1 ]) ! { dg-error "Expected coarray variable" }
   i = image_index(z, 2) ! { dg-error "must be a rank one array" }
 end subroutine this_image_check