add c++/43145 tag to changelog and testcase

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

diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index e2089b2..8f764ef 100644 (file)
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -1,5 +1,6 @@
 /* Intrinsic function resolution.
-   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+   Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+   2009, 2010
    Free Software Foundation, Inc.
    Contributed by Andy Vaught & Katherine Holcomb
 
@@ -33,6 +34,7 @@ along with GCC; see the file COPYING3.  If not see
 #include "tree.h"
 #include "gfortran.h"
 #include "intrinsic.h"
+#include "constructor.h"
 
 /* Given printf-like arguments, return a stable version of the result string. 
 
@@ -67,12 +69,18 @@ check_charlen_present (gfc_expr *source)
 
   if (source->expr_type == EXPR_CONSTANT)
     {
-      source->ts.u.cl->length = gfc_int_expr (source->value.character.length);
+      source->ts.u.cl->length
+               = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+                                   source->value.character.length);
       source->rank = 0;
     }
   else if (source->expr_type == EXPR_ARRAY)
-    source->ts.u.cl->length =
-       gfc_int_expr (source->value.constructor->expr->value.character.length);
+    {
+      gfc_constructor *c = gfc_constructor_first (source->value.constructor);
+      source->ts.u.cl->length
+               = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+                                   c->expr->value.character.length);
+    }
 }
 
 /* Helper function for resolving the "mask" argument.  */
@@ -111,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 **********************/
 
 
@@ -162,7 +191,7 @@ gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind,
   f->ts.kind = (kind == NULL)
             ? gfc_default_character_kind : mpz_get_si (kind->value.integer);
   f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
-  f->ts.u.cl->length = gfc_int_expr (1);
+  f->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
 
   f->value.function.name = gfc_get_string (name, f->ts.kind,
                                           gfc_type_letter (x->ts.type),
@@ -487,7 +516,8 @@ gfc_resolve_cmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y, gfc_expr *kind)
 void
 gfc_resolve_dcmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y)
 {
-  gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind));
+  gfc_resolve_cmplx (f, x, y, gfc_get_int_expr (gfc_default_integer_kind, NULL,
+                                               gfc_default_double_kind));
 }
 
 
@@ -823,7 +853,7 @@ gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
     gfc_add_component_ref (a, "$vptr");
   else if (a->ts.type == BT_DERIVED)
     {
-      vtab = gfc_find_derived_vtab (a->ts.u.derived);
+      vtab = gfc_find_derived_vtab (a->ts.u.derived, false);
       /* Clear the old expr.  */
       gfc_free_ref_list (a->ref);
       memset (a, '\0', sizeof (gfc_expr));
@@ -839,7 +869,7 @@ gfc_resolve_extends_type_of (gfc_expr *f, gfc_expr *a, gfc_expr *mo)
     gfc_add_component_ref (mo, "$vptr");
   else if (mo->ts.type == BT_DERIVED)
     {
-      vtab = gfc_find_derived_vtab (mo->ts.u.derived);
+      vtab = gfc_find_derived_vtab (mo->ts.u.derived, false);
       /* Clear the old expr.  */
       gfc_free_ref_list (mo->ref);
       memset (mo, '\0', sizeof (gfc_expr));
@@ -912,7 +942,7 @@ gfc_resolve_gamma (gfc_expr *f, gfc_expr *x)
 {
   f->ts = x->ts;
   f->value.function.name
-    = gfc_get_string ("__gamma_%d", x->ts.kind);
+    = gfc_get_string ("__tgamma_%d", x->ts.kind);
 }
 
 
@@ -1238,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";
-
-  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, "__lbound");
+}
 
-  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");
 }
 
 
@@ -1967,11 +1989,11 @@ gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
     {
       gfc_constructor *c;
       f->shape = gfc_get_shape (f->rank);
-      c = shape->value.constructor;
+      c = gfc_constructor_first (shape->value.constructor);
       for (i = 0; i < f->rank; i++)
        {
          mpz_init_set (f->shape[i], c->expr->value.integer);
-         c = c->next;
+         c = gfc_constructor_next (c);
        }
     }
 
@@ -2367,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;
@@ -2397,11 +2436,17 @@ gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
     {
       int len;
       if (mold->expr_type == EXPR_CONSTANT)
-       mold->ts.u.cl->length = gfc_int_expr (mold->value.character.length);
+        {
+         len = mold->value.character.length;
+         mold->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
+                                                   NULL, len);
+       }
       else
        {
-         len = mold->value.constructor->expr->value.character.length;
-         mold->ts.u.cl->length = gfc_int_expr (len);
+         gfc_constructor *c = gfc_constructor_first (mold->value.constructor);
+         len = c->expr->value.character.length;
+         mold->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
+                                                   NULL, len);
        }
     }
 
@@ -2495,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";
+  resolve_bound (f, array, dim, kind, "__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;
 
-  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");
 }