re PR fortran/18918 (Eventually support Fortran 2008's coarrays [co-arrays])

2010-04-14  Tobias Burnus  <burnus@net-b.de>

        PR fortran/18918
        * array.c (gfc_find_array_ref): Handle codimensions.
        (gfc_match_array_spec,gfc_match_array_ref): Use gfc_fatal_error.
        * check.c (is_coarray, dim_corank_check, gfc_check_lcobound,
        gfc_check_image_index, gfc_check_this_image, gfc_check_ucobound):
        New functions.
        * gfortran.h (gfc_isym_id): Add GFC_ISYM_IMAGE_INDEX,
        GFC_ISYM_LCOBOUND, GFC_ISYM_THIS_IMAGE,
        GFC_ISYM_UCOBOUND.
        * intrinsic.h (add_functions): Add this_image, image_index,
        lcobound and ucobound intrinsics.
        * intrinsic.c (gfc_check_lcobound,gfc_check_ucobound,
        gfc_check_image_index, gfc_check_this_image,
        gfc_simplify_image_index, gfc_simplify_lcobound,
        gfc_simplify_this_image, gfc_simplify_ucobound):
        New function prototypes.
        * intrinsic.texi (IMAGE_INDEX, LCOBOUND, THIS_IMAGE
        IMAGE_INDEX): Document new intrinsic functions.
        * match.c (gfc_match_critical, sync_statement): Make
        * -fcoarray=none
        error fatal.
        * simplify.c (simplify_bound_dim): Handle coarrays.
        (simplify_bound): Update simplify_bound_dim call.
        (gfc_simplify_num_images): Add -fcoarray=none check.
        (simplify_cobound, gfc_simplify_lcobound, gfc_simplify_ucobound,
        gfc_simplify_ucobound, gfc_simplify_ucobound): New functions.

2010-04-14  Tobias Burnus  <burnus@net-b.de>

        PR fortran/18918
        * gfortran.dg/coarray_9.f90: Update dg-errors.
        * gfortran.dg/coarray_10.f90: New test.
        * gfortran.dg/coarray_11.f90: New test.

From-SVN: r158292

gcc/fortran/ChangeLog

+2010-04-14  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* array.c (gfc_find_array_ref): Handle codimensions.
+	(gfc_match_array_spec,gfc_match_array_ref): Use gfc_fatal_error.
+	* check.c (is_coarray, dim_corank_check, gfc_check_lcobound,
+	gfc_check_image_index, gfc_check_this_image, gfc_check_ucobound):
+	New functions.
+	* gfortran.h (gfc_isym_id): Add GFC_ISYM_IMAGE_INDEX,
+	GFC_ISYM_LCOBOUND, GFC_ISYM_THIS_IMAGE,
+	GFC_ISYM_UCOBOUND.
+	* intrinsic.h (add_functions): Add this_image, image_index,
+	lcobound and ucobound intrinsics.
+	* intrinsic.c (gfc_check_lcobound,gfc_check_ucobound,
+	gfc_check_image_index, gfc_check_this_image,
+	gfc_simplify_image_index, gfc_simplify_lcobound,
+	gfc_simplify_this_image, gfc_simplify_ucobound):
+	New function prototypes.
+	* intrinsic.texi (IMAGE_INDEX, LCOBOUND, THIS_IMAGE
+	IMAGE_INDEX): Document new intrinsic functions.
+	* match.c (gfc_match_critical, sync_statement): Make -fcoarray=none
+	error fatal.
+	* simplify.c (simplify_bound_dim): Handle coarrays.
+	(simplify_bound): Update simplify_bound_dim call.
+	(gfc_simplify_num_images): Add -fcoarray=none check.
+	(simplify_cobound, gfc_simplify_lcobound, gfc_simplify_ucobound,
+	gfc_simplify_ucobound, gfc_simplify_ucobound): New functions.
+
 2010-04-14  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR fortran/43747

gcc/fortran/array.c

@@ -210,7 +210,7 @@ coarray:
 
   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
     {
-      gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+      gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
       return MATCH_ERROR;
     }
 
@@ -531,7 +531,7 @@ coarray:
 
   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
     {
-      gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+      gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
       goto cleanup;
     }
 
@@ -2223,7 +2223,8 @@ gfc_find_array_ref (gfc_expr *e)
 
   for (ref = e->ref; ref; ref = ref->next)
     if (ref->type == REF_ARRAY
-	&& (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
+	&& (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION
+	    || (ref->u.ar.type == AR_ELEMENT && ref->u.ar.dimen == 0)))
       break;
 
   if (ref == NULL)

gcc/fortran/check.c

 /* Check functions
-   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
    Free Software Foundation, Inc.
    Contributed by Andy Vaught & Katherine Holcomb
 
@@ -183,6 +183,32 @@ double_check (gfc_expr *d, int n)
 }
 
 
+/* Check whether an expression is a coarray (without array designator).  */
+
+static bool
+is_coarray (gfc_expr *e)
+{
+  bool coarray = false;
+  gfc_ref *ref;
+
+  if (e->expr_type != EXPR_VARIABLE)
+    return false;
+
+  coarray = e->symtree->n.sym->attr.codimension;
+
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_COMPONENT)
+	coarray = ref->u.c.component->attr.codimension;
+      else if (ref->type != REF_ARRAY || ref->u.ar.dimen != 0
+	       || ref->u.ar.codimen != 0) 
+	coarray = false;
+    }
+
+  return coarray;
+}
+
+
 /* Make sure the expression is a logical array.  */
 
 static gfc_try
@@ -329,6 +355,36 @@ dim_check (gfc_expr *dim, int n, bool optional)
 }
 
 
+/* If a coarray DIM parameter is a constant, make sure that it is greater than
+   zero and less than or equal to the corank of the given array.  */
+
+static gfc_try
+dim_corank_check (gfc_expr *dim, gfc_expr *array)
+{
+  gfc_array_ref *ar;
+  int corank;
+
+  gcc_assert (array->expr_type == EXPR_VARIABLE);
+
+  if (dim->expr_type != EXPR_CONSTANT)
+    return SUCCESS;
+
+  ar = gfc_find_array_ref (array);
+  corank = ar->as->corank;
+
+  if (mpz_cmp_ui (dim->value.integer, 1) < 0
+      || mpz_cmp_ui (dim->value.integer, corank) > 0)
+    {
+      gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid "
+		 "codimension index", gfc_current_intrinsic, &dim->where);
+
+      return FAILURE;
+    }
+
+  return SUCCESS;
+}
+
+
 /* If a DIM parameter is a constant, make sure that it is greater than
    zero and less than or equal to the rank of the given array.  If
    allow_assumed is zero then dim must be less than the rank of the array
@@ -1641,6 +1697,38 @@ gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 
 
 gfc_try
+gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
+{
+  if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+    {
+      gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+      return FAILURE;
+    }
+
+  if (!is_coarray (coarray))
+    {
+      gfc_error ("Expected coarray variable as '%s' argument to the LCOBOUND "
+                 "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where);
+      return FAILURE;
+    }
+
+  if (dim != NULL)
+    {
+      if (dim_check (dim, 1, false) == FAILURE)
+        return FAILURE;
+
+      if (dim_corank_check (dim, coarray) == FAILURE)
+        return FAILURE;
+    }
+
+  if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
+    return FAILURE;
+
+  return SUCCESS;
+}
+
+
+gfc_try
 gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind)
 {
   if (type_check (s, 0, BT_CHARACTER) == FAILURE)
@@ -3138,6 +3226,72 @@ gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status)
 
 
 gfc_try
+gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub)
+{
+  if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+    {
+      gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+      return FAILURE;
+    }
+
+  if (!is_coarray (coarray))
+    {
+      gfc_error ("Expected coarray variable as '%s' argument to IMAGE_INDEX "
+                "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where);
+      return FAILURE;
+    }
+
+  if (sub->rank != 1)
+    {
+      gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L",
+                gfc_current_intrinsic_arg[1], &sub->where);
+      return FAILURE;
+    }
+
+  return SUCCESS;
+}
+
+
+gfc_try
+gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim)
+{
+  if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+    {
+      gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+      return FAILURE;
+    }
+
+  if (dim != NULL &&  coarray == NULL)
+    {
+      gfc_error ("DIM argument without ARRAY argument not allowed for THIS_IMAGE "
+                "intrinsic at %L", &dim->where);
+      return FAILURE;
+    }
+
+  if (coarray == NULL)
+    return SUCCESS;
+
+  if (!is_coarray (coarray))
+    {
+      gfc_error ("Expected coarray variable as '%s' argument to THIS_IMAGE "
+                "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where);
+      return FAILURE;
+    }
+
+  if (dim != NULL)
+    {
+      if (dim_check (dim, 1, false) == FAILURE)
+       return FAILURE;
+
+      if (dim_corank_check (dim, coarray) == FAILURE)
+       return FAILURE;
+    }
+
+  return SUCCESS;
+}
+
+
+gfc_try
 gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED,
 		    gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size)
 {
@@ -3198,6 +3352,38 @@ gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 
 
 gfc_try
+gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind)
+{
+  if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+    {
+      gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+      return FAILURE;
+    }
+
+  if (!is_coarray (coarray))
+    {
+      gfc_error ("Expected coarray variable as '%s' argument to the UCOBOUND "
+                "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where);
+      return FAILURE;
+    }
+
+  if (dim != NULL)
+    {
+      if (dim_check (dim, 1, false) == FAILURE)
+        return FAILURE;
+
+      if (dim_corank_check (dim, coarray) == FAILURE)
+        return FAILURE;
+    }
+
+  if (kind_check (kind, 2, BT_INTEGER) == FAILURE)
+    return FAILURE;
+
+  return SUCCESS;
+}
+
+
+gfc_try
 gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
 {
   mpz_t vector_size;

gcc/fortran/gfortran.h

@@ -404,6 +404,7 @@ enum gfc_isym_id
   GFC_ISYM_IDATE,
   GFC_ISYM_IEOR,
   GFC_ISYM_IERRNO,
+  GFC_ISYM_IMAGE_INDEX,
   GFC_ISYM_INDEX,
   GFC_ISYM_INT,
   GFC_ISYM_INT2,
@@ -423,6 +424,7 @@ enum gfc_isym_id
   GFC_ISYM_KILL,
   GFC_ISYM_KIND,
   GFC_ISYM_LBOUND,
+  GFC_ISYM_LCOBOUND,
   GFC_ISYM_LEADZ,
   GFC_ISYM_LEN,
   GFC_ISYM_LEN_TRIM,
@@ -509,6 +511,7 @@ enum gfc_isym_id
   GFC_ISYM_SYSTEM_CLOCK,
   GFC_ISYM_TAN,
   GFC_ISYM_TANH,
+  GFC_ISYM_THIS_IMAGE,
   GFC_ISYM_TIME,
   GFC_ISYM_TIME8,
   GFC_ISYM_TINY,
@@ -518,6 +521,7 @@ enum gfc_isym_id
   GFC_ISYM_TRIM,
   GFC_ISYM_TTYNAM,
   GFC_ISYM_UBOUND,
+  GFC_ISYM_UCOBOUND,
   GFC_ISYM_UMASK,
   GFC_ISYM_UNLINK,
   GFC_ISYM_UNPACK,

gcc/fortran/intrinsic.c

@@ -1081,7 +1081,8 @@ add_functions (void)
     *y = "y", *sz = "size", *sta = "string_a", *stb = "string_b",
     *z = "z", *ln = "len", *ut = "unit", *han = "handler",
     *num = "number", *tm = "time", *nm = "name", *md = "mode",
-    *vl = "values", *p1 = "path1", *p2 = "path2", *com = "command";
+    *vl = "values", *p1 = "path1", *p2 = "path2", *com = "command",
+    *ca = "coarray", *sub = "sub";
 
   int di, dr, dd, dl, dc, dz, ii;
 
@@ -1784,6 +1785,10 @@ add_functions (void)
 
   make_generic ("ierrno", GFC_ISYM_IERRNO, GFC_STD_GNU);
 
+  add_sym_2 ("image_index", GFC_ISYM_IMAGE_INDEX, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008,
+	     gfc_check_image_index, gfc_simplify_image_index, NULL,
+	     ca, BT_REAL, dr, REQUIRED, sub, BT_INTEGER, ii, REQUIRED);
+
   /* The resolution function for INDEX is called gfc_resolve_index_func
      because the name gfc_resolve_index is already used in resolve.c.  */
   add_sym_4 ("index", GFC_ISYM_INDEX, CLASS_ELEMENTAL, ACTUAL_YES,
@@ -1919,6 +1924,14 @@ add_functions (void)
 
   make_generic ("lbound", GFC_ISYM_LBOUND, GFC_STD_F95);
 
+  add_sym_3 ("lcobound", GFC_ISYM_LCOBOUND, CLASS_INQUIRY, ACTUAL_NO,
+	     BT_INTEGER, di, GFC_STD_F95,
+	     gfc_check_lcobound, gfc_simplify_lcobound, NULL,
+	     ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
+	     kind, BT_INTEGER, di, OPTIONAL);
+
+  make_generic ("lcobound", GFC_ISYM_LCOBOUND, GFC_STD_F95);
+
   add_sym_1 ("leadz", GFC_ISYM_LEADZ, CLASS_ELEMENTAL, ACTUAL_NO,
 	     BT_INTEGER, di, GFC_STD_F2008,
 	     gfc_check_i, gfc_simplify_leadz, NULL,
@@ -2526,6 +2539,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,
+	     gfc_check_this_image, gfc_simplify_this_image, NULL,
+	     ca, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL);
+
   add_sym_0 ("time", GFC_ISYM_TIME, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, 
 	     NULL, NULL, gfc_resolve_time);
 
@@ -2582,6 +2599,14 @@ add_functions (void)
 
   make_generic ("ubound", GFC_ISYM_UBOUND, GFC_STD_F95);
 
+  add_sym_3 ("ucobound", GFC_ISYM_UCOBOUND, CLASS_INQUIRY, ACTUAL_NO,
+            BT_INTEGER, di, GFC_STD_F95,
+            gfc_check_ucobound, gfc_simplify_ucobound, NULL,
+            ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
+            kind, BT_INTEGER, di, OPTIONAL);
+
+  make_generic ("ucobound", GFC_ISYM_UCOBOUND, GFC_STD_F95);
+
   /* g77 compatibility for UMASK.  */
   add_sym_1 ("umask", GFC_ISYM_UMASK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
 	     GFC_STD_GNU, gfc_check_umask, NULL, gfc_resolve_umask,

gcc/fortran/intrinsic.h

@@ -91,6 +91,7 @@ gfc_try gfc_check_ishftc (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_try gfc_check_kill (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_kind (gfc_expr *);
 gfc_try gfc_check_lbound (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_try gfc_check_lcobound (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_try gfc_check_len_lentrim (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_link (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_lge_lgt_lle_llt (gfc_expr *, gfc_expr *);
@@ -143,6 +144,7 @@ gfc_try gfc_check_transpose (gfc_expr *);
 gfc_try gfc_check_trim (gfc_expr *);
 gfc_try gfc_check_ttynam (gfc_expr *);
 gfc_try gfc_check_ubound (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_try gfc_check_ucobound (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_try gfc_check_umask (gfc_expr *);
 gfc_try gfc_check_unlink (gfc_expr *);
 gfc_try gfc_check_unpack (gfc_expr *, gfc_expr *, gfc_expr *);
@@ -178,6 +180,7 @@ gfc_try gfc_check_fseek_sub (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_try gfc_check_ftell_sub (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_getcwd_sub (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_hostnm_sub (gfc_expr *, gfc_expr *);
+gfc_try gfc_check_image_index (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_itime_idate (gfc_expr *);
 gfc_try gfc_check_kill_sub (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_try gfc_check_ltime_gmtime (gfc_expr *, gfc_expr *);
@@ -189,6 +192,7 @@ gfc_try gfc_check_signal_sub (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_try gfc_check_sleep_sub (gfc_expr *);
 gfc_try gfc_check_stat_sub (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_try gfc_check_system_sub (gfc_expr *, gfc_expr *);
+gfc_try gfc_check_this_image (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_ttynam_sub (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_umask_sub (gfc_expr *, gfc_expr *);
 gfc_try gfc_check_unlink_sub (gfc_expr *, gfc_expr *);
@@ -255,6 +259,7 @@ gfc_expr *gfc_simplify_ibits (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_ibset (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_ichar (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_ieor (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_image_index (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_index (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_int (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_int2 (gfc_expr *);
@@ -270,6 +275,7 @@ gfc_expr *gfc_simplify_ishft (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_ishftc (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_kind (gfc_expr *);
 gfc_expr *gfc_simplify_lbound (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_lcobound (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_leadz (gfc_expr *);
 gfc_expr *gfc_simplify_len (gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_len_trim (gfc_expr *, gfc_expr *);
@@ -330,12 +336,14 @@ 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_tiny (gfc_expr *);
 gfc_expr *gfc_simplify_trailz (gfc_expr *);
 gfc_expr *gfc_simplify_transfer (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_transpose (gfc_expr *);
 gfc_expr *gfc_simplify_trim (gfc_expr *);
 gfc_expr *gfc_simplify_ubound (gfc_expr *, gfc_expr *, gfc_expr *);
+gfc_expr *gfc_simplify_ucobound (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_unpack (gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_verify (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
 gfc_expr *gfc_simplify_xor (gfc_expr *, gfc_expr *);

gcc/fortran/intrinsic.texi

@@ -154,6 +154,7 @@ Some basic guidelines for editing this document:
 * @code{INT8}:          INT8,      Convert to 64-bit integer type
 * @code{IOR}:           IOR,       Bitwise logical or
 * @code{IRAND}:         IRAND,     Integer pseudo-random number
+* @code{IMAGE_INDEX}:   IMAGE_INDEX, Cosubscript to image index convertion
 * @code{IS_IOSTAT_END}:  IS_IOSTAT_END, Test for end-of-file value
 * @code{IS_IOSTAT_EOR}:  IS_IOSTAT_EOR, Test for end-of-record value
 * @code{ISATTY}:        ISATTY,    Whether a unit is a terminal device
@@ -164,6 +165,7 @@ Some basic guidelines for editing this document:
 * @code{KILL}:          KILL,      Send a signal to a process
 * @code{KIND}:          KIND,      Kind of an entity
 * @code{LBOUND}:        LBOUND,    Lower dimension bounds of an array
+* @code{LCOBOUND}:      LCOBOUND,  Lower codimension bounds of an array
 * @code{LEADZ}:         LEADZ,     Number of leading zero bits of an integer
 * @code{LEN}:           LEN,       Length of a character entity
 * @code{LEN_TRIM}:      LEN_TRIM,  Length of a character entity without trailing blank characters
@@ -251,6 +253,7 @@ Some basic guidelines for editing this document:
 * @code{SYSTEM_CLOCK}:  SYSTEM_CLOCK, Time function
 * @code{TAN}:           TAN,       Tangent function
 * @code{TANH}:          TANH,      Hyperbolic tangent function
+* @code{THIS_IMAGE}:    THIS_IMAGE, Cosubscript index of this image
 * @code{TIME}:          TIME,      Time function
 * @code{TIME8}:         TIME8,     Time function (64-bit)
 * @code{TINY}:          TINY,      Smallest positive number of a real kind
@@ -260,6 +263,7 @@ Some basic guidelines for editing this document:
 * @code{TRIM}:          TRIM,      Remove trailing blank characters of a string
 * @code{TTYNAM}:        TTYNAM,    Get the name of a terminal device.
 * @code{UBOUND}:        UBOUND,    Upper dimension bounds of an array
+* @code{UCOBOUND}:      UCOBOUND,  Upper codimension bounds of an array
 * @code{UMASK}:         UMASK,     Set the file creation mask
 * @code{UNLINK}:        UNLINK,    Remove a file from the file system
 * @code{UNPACK}:        UNPACK,    Unpack an array of rank one into an array
@@ -6115,6 +6119,50 @@ end program test_irand
 
 
 
+@node IMAGE_INDEX
+@section @code{IMAGE_INDEX} --- Function that converts a cosubscript to an image index
+@fnindex IMAGE_INDEX
+@cindex coarray, IMAGE_INDEX
+@cindex images, cosubscript to image index conversion
+
+@table @asis
+@item @emph{Description}:
+Returns the image index belonging to a cosubscript.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Inquiry function.
+
+@item @emph{Syntax}:
+@code{RESULT = IMAGE_INDEX(COARRAY, SUB)}
+
+@item @emph{Arguments}: None.
+@multitable @columnfractions .15 .70
+@item @var{COARRAY} @tab Coarray of any type.
+@item @var{SUB}     @tab default integer rank-1 array of a size equal to
+the corank of @var{COARRAY}.
+@end multitable
+
+
+@item @emph{Return value}:
+Scalar default integer with the value of the image index which corresponds
+to the cosubscripts. For invalid cosubscripts the result is zero.
+
+@item @emph{Example}:
+@smallexample
+INTEGER :: array[2,-1:4,8,*]
+! Writes  28 (or 0 if there are fewer than 28 images)
+WRITE (*,*) IMAGE_INDEX (array, [2,0,3,1])
+@end smallexample
+
+@item @emph{See also}:
+@ref{THIS_IMAGE}, @ref{NUM_IMAGES}
+@end table
+
+
+
 @node IS_IOSTAT_END
 @section @code{IS_IOSTAT_END} --- Test for end-of-file value
 @fnindex IS_IOSTAT_END
@@ -6535,7 +6583,46 @@ structure component, or if it has a zero extent along the relevant
 dimension, the lower bound is taken to be 1.
 
 @item @emph{See also}:
-@ref{UBOUND}
+@ref{UBOUND}, @ref{LCOBOUND}
+@end table
+
+
+
+@node LCOBOUND
+@section @code{LCOBOUND} --- Lower codimension bounds of an array
+@fnindex LCOBOUND
+@cindex coarray, lower bound
+
+@table @asis
+@item @emph{Description}:
+Returns the lower bounds of a coarray, or a single lower cobound
+along the @var{DIM} codimension.
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = LCOBOUND(COARRAY [, DIM [, KIND]])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ARRAY} @tab Shall be an coarray, of any type.
+@item @var{DIM} @tab (Optional) Shall be a scalar @code{INTEGER}.
+@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
+expression indicating the kind parameter of the result.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of kind @var{KIND}. If
+@var{KIND} is absent, the return value is of default integer kind.
+If @var{DIM} is absent, the result is an array of the lower cobounds of
+@var{COARRAY}.  If @var{DIM} is present, the result is a scalar
+corresponding to the lower cobound of the array along that codimension.
+
+@item @emph{See also}:
+@ref{UCOBOUND}, @ref{LBOUND}
 @end table
 
 
@@ -8414,7 +8501,7 @@ END IF
 @end smallexample
 
 @item @emph{See also}:
-@c FIXME: ref{THIS_IMAGE}
+@ref{THIS_IMAGE}, @ref{IMAGE_INDEX}
 @end table
 
 
@@ -10654,6 +10741,64 @@ end program test_tanh
 
 
 
+@node THIS_IMAGE
+@section @code{THIS_IMAGE} --- Function that returns the cosubscript index of this image
+@fnindex THIS_IMAGE
+@cindex coarray, THIS_IMAGE
+@cindex images, index of this image
+
+@table @asis
+@item @emph{Description}:
+Returns the cosubscript for this image.
+
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Transformational function
+
+@item @emph{Syntax}:
+@multitable @columnfractions .80
+@item @code{RESULT = THIS_IMAGE()}
+@item @code{RESULT = THIS_IMAGE(COARRAY [, DIM])}
+@end multitable
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{COARRAY} @tab Coarray of any type  (optional; if @var{DIM}
+present, required).
+@item @var{DIM}     @tab default integer scalar (optional). If present,
+@var{DIM} shall be between one and the corank of @var{COARRAY}.
+@end multitable
+
+
+@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)}.
+
+@item @emph{Example}:
+@smallexample
+INTEGER :: value[*]
+INTEGER :: i
+value = THIS_IMAGE()
+SYNC ALL
+IF (THIS_IMAGE() == 1) THEN
+  DO i = 1, NUM_IMAGES()
+    WRITE(*,'(2(a,i0))') 'value[', i, '] is ', value[i]
+  END DO
+END IF
+@end smallexample
+
+@item @emph{See also}:
+@ref{NUM_IMAGES}, @ref{IMAGE_INDEX}
+@end table
+
+
+
 @node TIME
 @section @code{TIME} --- Time function
 @fnindex TIME
@@ -11030,7 +11175,46 @@ dimension, the upper bound is taken to be the number of elements along
 the relevant dimension.
 
 @item @emph{See also}:
-@ref{LBOUND}
+@ref{LBOUND}, @ref{LCOBOUND}
+@end table
+
+
+
+@node UCOBOUND
+@section @code{UCOBOUND} --- Upper codimension bounds of an array
+@fnindex UCOBOUND
+@cindex coarray, upper bound
+
+@table @asis
+@item @emph{Description}:
+Returns the upper cobounds of a coarray, or a single upper cobound
+along the @var{DIM} codimension.
+@item @emph{Standard}:
+Fortran 2008 and later
+
+@item @emph{Class}:
+Inquiry function
+
+@item @emph{Syntax}:
+@code{RESULT = UCOBOUND(COARRAY [, DIM [, KIND]])}
+
+@item @emph{Arguments}:
+@multitable @columnfractions .15 .70
+@item @var{ARRAY} @tab Shall be an coarray, of any type.
+@item @var{DIM} @tab (Optional) Shall be a scalar @code{INTEGER}.
+@item @var{KIND} @tab (Optional) An @code{INTEGER} initialization
+expression indicating the kind parameter of the result.
+@end multitable
+
+@item @emph{Return value}:
+The return value is of type @code{INTEGER} and of kind @var{KIND}. If
+@var{KIND} is absent, the return value is of default integer kind.
+If @var{DIM} is absent, the result is an array of the lower cobounds of
+@var{COARRAY}.  If @var{DIM} is present, the result is a scalar
+corresponding to the lower cobound of the array along that codimension.
+
+@item @emph{See also}:
+@ref{LCOBOUND}, @ref{LBOUND}
 @end table
 
 

gcc/fortran/match.c

@@ -1753,7 +1753,7 @@ gfc_match_critical (void)
 
   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
     {
-       gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+       gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
        return MATCH_ERROR;
     }
 
@@ -2154,7 +2154,7 @@ sync_statement (gfc_statement st)
 
   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
     {
-       gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+       gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
        return MATCH_ERROR;
     }
 

gcc/testsuite/ChangeLog

+2010-04-14  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* gfortran.dg/coarray_9.f90: Update dg-errors.
+	* gfortran.dg/coarray_10.f90: New test.
+	* gfortran.dg/coarray_11.f90: New test.
+
 2010-04-14  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR fortran/43747

gcc/testsuite/gfortran.dg/coarray_10.f90

+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! PR fortran/18918
+!
+! Coarray intrinsics
+!
+
+subroutine image_idx_test1()
+  INTEGER,save :: array[2,-1:4,8,*]
+  WRITE (*,*) IMAGE_INDEX (array, [2,0,3,1])
+  WRITE (*,*) IMAGE_INDEX (array, [0,0,3,1])  ! { dg-error "for dimension 1, SUB has 0 and COARRAY lower bound is 1" }
+  WRITE (*,*) IMAGE_INDEX (array, [1,2,9,0])  ! { dg-error "for dimension 3, SUB has 9 and COARRAY upper bound is 8" }
+  WRITE (*,*) IMAGE_INDEX (array, [2,0,3])    ! { dg-error "Too few elements" }
+  WRITE (*,*) IMAGE_INDEX (array, [2,0,3,1,1])! { dg-error "Too many elements" }
+end subroutine
+
+subroutine this_image_check()
+  integer,save :: a(1,2,3,5)[0:3,*]
+  integer :: j
+  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" }
+  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

gcc/testsuite/gfortran.dg/coarray_11.f90

+! { dg-do compile }
+! { dg-options "-fcoarray=single -fdump-tree-original" }
+!
+! PR fortran/18918
+!
+! Coarray intrinsics
+!
+
+subroutine image_idx_test1()
+  INTEGER,save :: array[2,-1:4,8,*]
+  WRITE (*,*) IMAGE_INDEX (array, [2,0,3,1])
+  if (IMAGE_INDEX (array, [1,-1,1,1]) /= 1) call not_existing()
+  if (IMAGE_INDEX (array, [2,-1,1,1]) /= 0) call not_existing()
+  if (IMAGE_INDEX (array, [1,-1,1,2]) /= 0) call not_existing()
+end subroutine
+
+subroutine this_image_check()
+  integer,save :: a(1,2,3,5)[0:3,*]
+  integer :: j
+  if (this_image() /= 1) call not_existing()
+  if (this_image(a,dim=1) /= 0) call not_existing()
+  if (this_image(a,dim=2) /= 1) call not_existing()
+end subroutine this_image_check
+
+subroutine othercheck()
+real,save :: a(5)[2,*]
+complex,save :: c[4:5,6,9:*]
+integer,save :: i, j[*]
+dimension :: b(3)
+codimension :: b[5:*]
+dimension :: h(9:10)
+codimension :: h[8:*]
+save :: b,h
+if (this_image() /= 1) call not_existing()
+if (num_images() /= 1) call not_existing()
+if(any(this_image(coarray=a) /= [ 1, 1 ])) call not_existing()
+if(any(this_image(c) /= [4,1,9])) call not_existing()
+if(this_image(c, dim=3) /= 9) call not_existing()
+if(ubound(b,dim=1) /= 3 .or. this_image(coarray=b,dim=1) /= 5) call not_existing()
+if(ubound(h,dim=1) /= 10 .or. this_image(h,dim=1) /= 8) call not_existing()
+end subroutine othercheck
+
+subroutine andanother()
+integer,save :: a(1)[2:9,4,-3:5,0:*]
+print *, lcobound(a)
+print *, lcobound(a,dim=3,kind=8)
+print *, ucobound(a)
+print *, ucobound(a,dim=1,kind=2)
+if (any(lcobound(a) /= [2, 1, -3, 0])) call not_existing()
+if (any(ucobound(a) /= [9, 4,  5, 0])) call not_existing()
+if (lcobound(a,dim=3,kind=8) /= -3_8)  call not_existing()
+if (ucobound(a,dim=1,kind=2) /=  9_2)  call not_existing()
+end subroutine andanother
+
+! { dg-final { scan-tree-dump-times "not_existing" 0 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }

gcc/testsuite/gfortran.dg/coarray_9.f90

@@ -9,9 +9,10 @@ integer :: a
 integer :: b[*] ! { dg-error "Coarrays disabled" }
 
 error stop "Error"
-sync all ! { dg-error "Coarrays disabled" }
+sync all !  "Coarrays disabled"  (but error above is fatal)
 
-critical ! { dg-error "Coarrays disabled" }
-end critical ! { dg-error "Expecting END PROGRAM statement" }
+critical ! "Coarrays disabled"  (but error above is fatal)
+
+end critical ! "Expecting END PROGRAM statement"  (but error above is fatal)
 
 end