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

[pf3gnuchains/gcc-fork.git] / gcc / fortran / simplify.c

diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index 60fbf01..53d8b93 100644 (file)
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -3075,30 +3075,41 @@ gfc_simplify_leadz (gfc_expr *e)
   unsigned long lz, bs;
   int i;
 
-  if (e->expr_type != EXPR_CONSTANT)
+  if (array->expr_type != EXPR_VARIABLE)
     return NULL;
 
-  i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
-  bs = gfc_integer_kinds[i].bit_size;
-  if (mpz_cmp_si (e->value.integer, 0) == 0)
-    lz = bs;
-  else if (mpz_cmp_si (e->value.integer, 0) < 0)
-    lz = 0;
-  else
-    lz = bs - mpz_sizeinbase (e->value.integer, 2);
+  /* 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:
+             if (ref->next == NULL)
+               {
+                 gcc_assert (ref->u.ar.as->corank > 0
+                             && ref->u.ar.as->rank == 0);
+                 as = ref->u.ar.as;
+                 goto done;
+               }
+             as = NULL;
+             continue;
 
   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
 }
 
+           case AR_UNKNOWN:
+             return NULL;
 
-gfc_expr *
-gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
-{
-  gfc_expr *result;
-  int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
+           case AR_SECTION:
+             as = ref->u.ar.as;
+             goto done;
+           }
 
-  if (k == -1)
-    return &gfc_bad_expr;
+         gcc_unreachable ();
 
   if (e->expr_type == EXPR_CONSTANT)
     {
@@ -3126,10 +3137,9 @@ gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
   int count, len, i;
   int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
 
-  if (k == -1)
-    return &gfc_bad_expr;
+ done:
 
-  if (e->expr_type != EXPR_CONSTANT)
+  if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
     return NULL;
 
   len = e->value.character.length;
@@ -3868,17 +3878,6 @@ gfc_simplify_num_images (void)
 
 
 gfc_expr *
-gfc_simplify_num_images (void)
-{
-  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;
-}
-
-
-gfc_expr *
 gfc_simplify_or (gfc_expr *x, gfc_expr *y)
 {
   gfc_expr *result;
@@ -5337,6 +5336,110 @@ gfc_simplify_trim (gfc_expr *e)
     result->value.character.string[i] = e->value.character.string[i];
 
   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_get_constant_expr (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;
+
+      /* 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.  */
+      for (d = 0; d < as->corank; d++)
+        gfc_constructor_append_expr (&e->value.constructor,
+                                     bounds[d], &e->where);
+
+      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;
 }