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

2010-05-02  Tobias Burnus  <burnus@net-b.de>

        PR fortran/18918
        * intrinsic.c (add_functions): Fix GFC_STD and add gfc_resolve_*
        calls for lcobound, ucobound, image_index and this_image.
        * intrinsic.h (gfc_resolve_lcobound, gfc_resolve_this_image,
        gfc_resolve_image_index, gfc_resolve_ucobound): New prototypes.
        * iresolve.c (gfc_resolve_lcobound, gfc_resolve_this_image,
        gfc_resolve_image_index, gfc_resolve_ucobound, resolve_bound): New
        functions.
        (gfc_resolve_lbound, gfc_resolve_ubound): Use resolve_bound.

From-SVN: r158974

1 files changed, 50 insertions, 28 deletions

diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 1c69f20..8f764ef 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -119,6 +119,27 @@ resolve_mask_arg (gfc_expr *mask)
     }
 }
 
+
+static void
+resolve_bound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind,
+	       const char *name)
+{
+  f->ts.type = BT_INTEGER;
+  if (kind)
+    f->ts.kind = mpz_get_si (kind->value.integer);
+  else
+    f->ts.kind = gfc_default_integer_kind;
+
+  if (dim == NULL)
+    {
+      f->rank = 1;
+      f->shape = gfc_get_shape (1);
+      mpz_init_set_ui (f->shape[0], array->rank);
+    }
+
+  f->value.function.name = xstrdup (name);
+}
+
 /********************** Resolution functions **********************/
 
 
@@ -1247,22 +1268,14 @@ gfc_resolve_kill (gfc_expr *f, gfc_expr *p ATTRIBUTE_UNUSED,
 void
 gfc_resolve_lbound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 {
-  static char lbound[] = "__lbound";
+  resolve_bound (f, array, dim, kind, "__lbound");
+}
 
-  f->ts.type = BT_INTEGER;
-  if (kind)
-    f->ts.kind = mpz_get_si (kind->value.integer);
-  else
-    f->ts.kind = gfc_default_integer_kind;
 
-  if (dim == NULL)
-    {
-      f->rank = 1;
-      f->shape = gfc_get_shape (1);
-      mpz_init_set_ui (f->shape[0], array->rank);
-    }
-
-  f->value.function.name = lbound;
+void
+gfc_resolve_lcobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+  resolve_bound (f, array, dim, kind, "__lcobound");
 }
 
 
@@ -2376,6 +2389,23 @@ gfc_resolve_tanh (gfc_expr *f, gfc_expr *x)
 
 
 void
+gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
+			 gfc_expr *sub ATTRIBUTE_UNUSED)
+{
+  static char this_image[] = "__image_index";
+  f->ts.kind = gfc_default_integer_kind;
+  f->value.function.name = this_image;
+}
+
+
+void
+gfc_resolve_this_image (gfc_expr *f, gfc_expr *array, gfc_expr *dim)
+{
+  resolve_bound (f, array, dim, NULL, "__this_image");
+}
+
+
+void
 gfc_resolve_time (gfc_expr *f)
 {
   f->ts.type = BT_INTEGER;
@@ -2510,22 +2540,14 @@ gfc_resolve_trim (gfc_expr *f, gfc_expr *string)
 void
 gfc_resolve_ubound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
 {
-  static char ubound[] = "__ubound";
-
-  f->ts.type = BT_INTEGER;
-  if (kind)
-    f->ts.kind = mpz_get_si (kind->value.integer);
-  else
-    f->ts.kind = gfc_default_integer_kind;
+  resolve_bound (f, array, dim, kind, "__ubound");
+}
 
-  if (dim == NULL)
-    {
-      f->rank = 1;
-      f->shape = gfc_get_shape (1);
-      mpz_init_set_ui (f->shape[0], array->rank);
-    }
 
-  f->value.function.name = ubound;
+void
+gfc_resolve_ucobound (gfc_expr *f, gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
+{
+  resolve_bound (f, array, dim, kind, "__ucobound");
 }