This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[Patch,Fortran] Coarrays 8/n: Add intrinsics (part 1) (PR 18918)


The current coarray implementation status and a short coarray
introduction can be found at:

   http://users.physik.fu-berlin.de/~tburnus/coarray/README.txt

 * * *

This patch adds the most important missing feature:  THIS_IMAGE() (which
evaluates to 1) - and allows now to compile most simpler coarray
programs. (More complicated ones use allocatable coarrays.)

Additionally, it adds THIS_IMAGE(coarray[, dim]), IMAGE_INDEX(coarray,
sub), UCOBOUND(coarray[, dim) and LCOBOUND(coarray[, dim]) for the case
that the cobounds are known at compile time.

Build and regtested on x86-64-linux.
OK for the trunk?

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

	PR fortran/18918
	* array.c (gfc_find_array_ref): Handle codimensions.
	* 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-10  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.

 fortran/array.c                      |    3 
 fortran/check.c                      |  188 +++++++++++++++
 fortran/gfortran.h                   |    4 
 fortran/intrinsic.c                  |   27 ++
 fortran/intrinsic.h                  |    8 
 fortran/intrinsic.texi               |  190 +++++++++++++++
 fortran/match.c                      |    4 
 fortran/simplify.c                   |  434 ++++++++++++++++++++++++++++++++++-
 testsuite/gfortran.dg/coarray_10.f90 |   28 ++
 testsuite/gfortran.dg/coarray_11.f90 |   56 ++++
 testsuite/gfortran.dg/coarray_9.f90  |    7 
 11 files changed, 932 insertions(+), 17 deletions(-)

diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index 5ceca4b..b0c07bd 100644
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -2449,7 +2449,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)
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 9b6f8ea..ed14f57 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -1,5 +1,5 @@
 /* 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
 
@@ -182,6 +182,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
@@ -328,6 +354,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
@@ -1640,6 +1696,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)
@@ -3144,6 +3232,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)
 {
@@ -3204,6 +3358,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;
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 3668df4..9d916cd 100644
--- a/gcc/fortran/gfortran.h
+++ b/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,
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index fbfc47a..470839a 100644
--- a/gcc/fortran/intrinsic.c
+++ b/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,
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index b675de2..de33a4f 100644
--- a/gcc/fortran/intrinsic.h
+++ b/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 *);
diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi
index 4439464..63b8b2b 100644
--- a/gcc/fortran/intrinsic.texi
+++ b/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
 
 
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 2709de7..12aceb0 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1752,7 +1752,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;
     }
 
@@ -2153,7 +2153,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;
     }
 
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 50cd6da..c394345 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -2890,13 +2890,14 @@ gfc_simplify_kind (gfc_expr *e)
 
 static gfc_expr *
 simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
-		    gfc_array_spec *as, gfc_ref *ref)
+		    gfc_array_spec *as, gfc_ref *ref, bool coarray)
 {
   gfc_expr *l, *u, *result;
   int k;
 
   /* The last dimension of an assumed-size array is special.  */
-  if (d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
+  if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
+      || (coarray && d == as->rank + as->corank))
     {
       if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
 	return gfc_copy_expr (as->lower[d-1]);
@@ -2913,12 +2914,13 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
 
 
   /* Then, we need to know the extent of the given dimension.  */
-  if (ref->u.ar.type == AR_FULL)
+  if (coarray || ref->u.ar.type == AR_FULL)
     {
       l = as->lower[d-1];
       u = as->upper[d-1];
 
-      if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT)
+      if (l->expr_type != EXPR_CONSTANT || u == NULL
+	  || u->expr_type != EXPR_CONSTANT)
 	return NULL;
 
       if (mpz_cmp (l->value.integer, u->value.integer) > 0)
@@ -3030,7 +3032,8 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
       /* Simplify the bounds for each dimension.  */
       for (d = 0; d < array->rank; d++)
 	{
-	  bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref);
+	  bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref,
+					  false);
 	  if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
 	    {
 	      int j;
@@ -3096,7 +3099,154 @@ simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
 	  return &gfc_bad_expr;
 	}
 
-      return simplify_bound_dim (array, kind, d, upper, as, ref);
+      return simplify_bound_dim (array, kind, d, upper, as, ref, false);
+    }
+}
+
+
+static gfc_expr *
+simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
+{
+  gfc_ref *ref;
+  gfc_array_spec *as;
+  int d;
+
+  if (array->expr_type != EXPR_VARIABLE)
+    return NULL;
+
+  /* Follow any component references.  */
+  as = array->symtree->n.sym->as;
+  for (ref = array->ref; ref; ref = ref->next)
+    {
+      switch (ref->type)
+	{
+	case REF_ARRAY:
+	  switch (ref->u.ar.type)
+	    {
+	    case AR_ELEMENT:
+	      as = NULL;
+	      continue;
+
+	    case AR_FULL:
+	      /* We're done because 'as' has already been set in the
+		 previous iteration.  */
+	      if (!ref->next)
+	        goto done;
+
+	    /* Fall through.  */
+
+	    case AR_UNKNOWN:
+	      return NULL;
+
+	    case AR_SECTION:
+	      as = ref->u.ar.as;
+	      goto done;
+	    }
+
+	  gcc_unreachable ();
+
+	case REF_COMPONENT:
+	  as = ref->u.c.component->as;
+	  continue;
+
+	case REF_SUBSTRING:
+	  continue;
+	}
+    }
+
+  gcc_unreachable ();
+
+ done:
+
+  if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
+    return NULL;
+
+  if (dim == NULL)
+    {
+      /* Multi-dimensional bounds.  */
+      gfc_expr *bounds[GFC_MAX_DIMENSIONS];
+      gfc_expr *e;
+      gfc_constructor *head, *tail;
+      int k;
+
+      /* UBOUND(ARRAY) is not valid for an assumed-size array.  */
+      if (upper && as->type == AS_ASSUMED_SIZE)
+	{
+	  /* An error message will be emitted in
+	     check_assumed_size_reference (resolve.c).  */
+	  return &gfc_bad_expr;
+	}
+
+      /* Simplify the bounds for each dimension.  */
+      for (d = 0; d < as->corank; d++)
+	{
+	  bounds[d] = simplify_bound_dim (array, kind, d + 1 + array->rank,
+					  upper, as, ref, true);
+	  if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
+	    {
+	      int j;
+
+	      for (j = 0; j < d; j++)
+		gfc_free_expr (bounds[j]);
+	      return bounds[d];
+	    }
+	}
+
+      /* Allocate the result expression.  */
+      e = gfc_get_expr ();
+      e->where = array->where;
+      e->expr_type = EXPR_ARRAY;
+      e->ts.type = BT_INTEGER;
+      k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND",
+		    gfc_default_integer_kind); 
+      if (k == -1)
+	{
+	  gfc_free_expr (e);
+	  return &gfc_bad_expr;
+	}
+      e->ts.kind = k;
+
+      /* The result is a rank 1 array; its size is the rank of the first
+	 argument to {L,U}COBOUND.  */
+      e->rank = 1;
+      e->shape = gfc_get_shape (1);
+      mpz_init_set_ui (e->shape[0], as->corank);
+
+      /* Create the constructor for this array.  */
+      head = tail = NULL;
+      for (d = 0; d < as->corank; d++)
+	{
+	  /* Get a new constructor element.  */
+	  if (head == NULL)
+	    head = tail = gfc_get_constructor ();
+	  else
+	    {
+	      tail->next = gfc_get_constructor ();
+	      tail = tail->next;
+	    }
+
+	  tail->where = e->where;
+	  tail->expr = bounds[d];
+	}
+      e->value.constructor = head;
+
+      return e;
+    }
+  else
+    {
+      /* A DIM argument is specified.  */
+      if (dim->expr_type != EXPR_CONSTANT)
+	return NULL;
+
+      d = mpz_get_si (dim->value.integer);
+
+      if (d < 1 || d > as->corank)
+	{
+	  gfc_error ("DIM argument at %L is out of bounds", &dim->where);
+	  return &gfc_bad_expr;
+	}
+
+      return simplify_bound_dim (array, kind, d+array->rank, upper, as, ref, true);
     }
 }
 
@@ -3109,6 +3259,21 @@ gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 
 
 gfc_expr *
+gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+  gfc_expr *e;
+  /* return simplify_cobound (array, dim, kind, 0);*/
+
+  e = simplify_cobound (array, dim, kind, 0);
+  if (e != NULL)
+    return e;
+
+  gfc_error ("Not yet implemented: LCOBOUND for coarray with non-constant "
+	     "cobounds at %L", &e->where);
+  return &gfc_bad_expr;
+}
+
+gfc_expr *
 gfc_simplify_leadz (gfc_expr *e)
 {
   gfc_expr *result;
@@ -3939,6 +4104,13 @@ gfc_expr *
 gfc_simplify_num_images (void)
 {
   gfc_expr *result;
+
+  if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+    {
+      gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+      return &gfc_bad_expr;
+    }
+
   /* FIXME: gfc_current_locus is wrong.  */
   result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus);
   mpz_set_si (result->value.integer, 1);
@@ -5489,11 +5661,261 @@ gfc_simplify_trim (gfc_expr *e)
 
 
 gfc_expr *
+gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
+{
+  gfc_expr *result;
+  gfc_ref *ref;
+  gfc_array_spec *as;
+  gfc_constructor *sub_cons;
+  bool first_image;
+  int d;
+
+  if (!is_constant_array_expr (sub))
+    goto not_implemented; /* return NULL;*/
+
+  /* Follow any component references.  */
+  as = coarray->symtree->n.sym->as;
+  for (ref = coarray->ref; ref; ref = ref->next)
+    if (ref->type == REF_COMPONENT)
+      as = ref->u.ar.as;
+
+  if (as->type == AS_DEFERRED)
+    goto not_implemented; /* return NULL;*/
+
+  /* "valid sequence of cosubscripts" are required; thus, return 0 unless
+     the cosubscript addresses the first image.  */
+
+  sub_cons = sub->value.constructor;
+  first_image = true;
+
+  for (d = 1; d <= as->corank; d++)
+    {
+      gfc_expr *ca_bound;
+      int cmp;
+
+      if (sub_cons == NULL)
+	{
+	  gfc_error ("Too few elements in expression for SUB= argument at %L",
+		     &sub->where);
+	  return &gfc_bad_expr;
+	}
+
+      ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
+				     NULL, true);
+      if (ca_bound == NULL)
+	goto not_implemented; /* return NULL */
+
+      if (ca_bound == &gfc_bad_expr)
+	return ca_bound;
+
+      cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer);
+
+      if (cmp == 0)
+	{
+          gfc_free_expr (ca_bound);
+	  sub_cons = sub_cons->next;
+	  continue;
+	}
+
+      first_image = false;
+
+      if (cmp > 0)
+	{
+	  gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
+		     "SUB has %ld and COARRAY lower bound is %ld)",
+		     &coarray->where, d,
+		     mpz_get_si (sub_cons->expr->value.integer),
+		     mpz_get_si (ca_bound->value.integer));
+	  gfc_free_expr (ca_bound);
+	  return &gfc_bad_expr;
+	}
+
+      gfc_free_expr (ca_bound);
+
+      /* Check whether upperbound is valid for the multi-images case.  */
+      if (d < as->corank)
+	{
+	  ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as,
+					 NULL, true);
+	  if (ca_bound == &gfc_bad_expr)
+	    return ca_bound;
+
+	  if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT
+	      && mpz_cmp (ca_bound->value.integer,
+			  sub_cons->expr->value.integer) < 0)
+	  {
+	    gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
+		       "SUB has %ld and COARRAY upper bound is %ld)",
+		       &coarray->where, d,
+		       mpz_get_si (sub_cons->expr->value.integer),
+		       mpz_get_si (ca_bound->value.integer));
+	    gfc_free_expr (ca_bound);
+	    return &gfc_bad_expr;
+	  }
+
+	  if (ca_bound)
+	    gfc_free_expr (ca_bound);
+	}
+
+      sub_cons = sub_cons->next;
+    }
+
+  if (sub_cons != NULL)
+    {
+      gfc_error ("Too many elements in expression for SUB= argument at %L",
+		 &sub->where);
+      return &gfc_bad_expr;
+    }
+
+  result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
+				&gfc_current_locus);
+  if (first_image)
+    mpz_set_si (result->value.integer, 1);
+  else
+    mpz_set_si (result->value.integer, 0);
+
+  return result;
+
+not_implemented:
+  gfc_error ("Not yet implemented: IMAGE_INDEX for coarray with non-constant "
+	     "cobounds at %L", &coarray->where);
+  return &gfc_bad_expr;
+}
+
+
+gfc_expr *
+gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
+{
+  gfc_ref *ref;
+  gfc_array_spec *as;
+  int d;
+
+  if (coarray == NULL)
+    {
+      gfc_expr *result;
+      /* FIXME: gfc_current_locus is wrong.  */
+      result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus);
+      mpz_set_si (result->value.integer, 1);
+      return result;
+    }
+
+  gcc_assert (coarray->expr_type == EXPR_VARIABLE);
+
+  /* Follow any component references.  */
+  as = coarray->symtree->n.sym->as;
+  for (ref = coarray->ref; ref; ref = ref->next)
+    if (ref->type == REF_COMPONENT)
+      as = ref->u.ar.as;
+
+  if (as->type == AS_DEFERRED)
+    goto not_implemented; /* return NULL;*/
+
+  if (dim == NULL)
+    {
+      /* Multi-dimensional bounds.  */
+      gfc_expr *bounds[GFC_MAX_DIMENSIONS];
+      gfc_expr *e;
+      gfc_constructor *head, *tail;
+
+      /* Simplify the bounds for each dimension.  */
+      for (d = 0; d < as->corank; d++)
+	{
+	  bounds[d] = simplify_bound_dim (coarray, NULL, d + as->rank + 1, 0,
+					  as, NULL, true);
+	  if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
+	    {
+	      int j;
+
+	      for (j = 0; j < d; j++)
+		gfc_free_expr (bounds[j]);
+	      if (bounds[d] == NULL)
+		goto not_implemented;
+	      return bounds[d];
+	    }
+	}
+
+      /* Allocate the result expression.  */
+      e = gfc_get_expr ();
+      e->where = coarray->where;
+      e->expr_type = EXPR_ARRAY;
+      e->ts.type = BT_INTEGER;
+      e->ts.kind = gfc_default_integer_kind;
+
+      e->rank = 1;
+      e->shape = gfc_get_shape (1);
+      mpz_init_set_ui (e->shape[0], as->corank);
+
+      /* Create the constructor for this array.  */
+      head = tail = NULL;
+      for (d = 0; d < as->corank; d++)
+	{
+	  /* Get a new constructor element.  */
+	  if (head == NULL)
+	    head = tail = gfc_get_constructor ();
+	  else
+	    {
+	      tail->next = gfc_get_constructor ();
+	      tail = tail->next;
+	    }
+
+	  tail->where = e->where;
+	  tail->expr = bounds[d];
+	}
+      e->value.constructor = head;
+
+      return e;
+    }
+  else
+    {
+      gfc_expr *e;
+      /* A DIM argument is specified.  */
+      if (dim->expr_type != EXPR_CONSTANT)
+	goto not_implemented; /*return NULL;*/
+
+      d = mpz_get_si (dim->value.integer);
+
+      if (d < 1 || d > as->corank)
+	{
+	  gfc_error ("DIM argument at %L is out of bounds", &dim->where);
+	  return &gfc_bad_expr;
+	}
+
+      /*return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);*/
+      e = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);
+      if (e != NULL)
+	return e;
+      else
+	goto not_implemented;
+   }
+
+not_implemented:
+  gfc_error ("Not yet implemented: THIS_IMAGE for coarray with non-constant "
+	     "cobounds at %L", &coarray->where);
+  return &gfc_bad_expr;
+}
+
+
+gfc_expr *
 gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 {
   return simplify_bound (array, dim, kind, 1);
 }
 
+gfc_expr *
+gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+  gfc_expr *e;
+  /* return simplify_cobound (array, dim, kind, 1);*/
+
+  e = simplify_cobound (array, dim, kind, 1);
+  if (e != NULL)
+    return e;
+
+  gfc_error ("Not yet implemented: UCOBOUND for coarray with non-constant "
+	     "cobounds at %L", &e->where);
+  return &gfc_bad_expr;
+}
+
 
 gfc_expr *
 gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
diff --git a/gcc/testsuite/gfortran.dg/coarray_10.f90 b/gcc/testsuite/gfortran.dg/coarray_10.f90
new file mode 100644
index 0000000..7a50c89
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_10.f90
@@ -0,0 +1,28 @@
+! { 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
diff --git a/gcc/testsuite/gfortran.dg/coarray_11.f90 b/gcc/testsuite/gfortran.dg/coarray_11.f90
new file mode 100644
index 0000000..969d491
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray_11.f90
@@ -0,0 +1,56 @@
+! { 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" } }
diff --git a/gcc/testsuite/gfortran.dg/coarray_9.f90 b/gcc/testsuite/gfortran.dg/coarray_9.f90
index d44cdda..cdfb4dc 100644
--- a/gcc/testsuite/gfortran.dg/coarray_9.f90
+++ b/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

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]