PR fortran/29784

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

diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index fc837e1..6de83ee 100644 (file)
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -62,14 +62,24 @@ gfc_get_string (const char *format, ...)
 static void
 check_charlen_present (gfc_expr *source)
 {
-  if (source->expr_type == EXPR_CONSTANT && source->ts.cl == NULL)
+  if (source->ts.cl == NULL)
     {
       source->ts.cl = gfc_get_charlen ();
       source->ts.cl->next = gfc_current_ns->cl_list;
       gfc_current_ns->cl_list = source->ts.cl;
+    }
+
+  if (source->expr_type == EXPR_CONSTANT)
+    {
       source->ts.cl->length = gfc_int_expr (source->value.character.length);
       source->rank = 0;
     }
+  else if (source->expr_type == EXPR_ARRAY)
+    {
+      source->ts.cl->length =
+       gfc_int_expr (source->value.constructor->expr->value.character.length);
+      source->rank = 1;
+    }
 }
 
 /* Helper function for resolving the "mask" argument.  */
@@ -78,18 +88,32 @@ static void
 resolve_mask_arg (gfc_expr *mask)
 {
 
-  /* The mask can be any kind for an array.
-     For the scalar case, coerce it to kind=4 unconditionally
-     (because this is the only kind we have a library function
-     for).  */
+  gfc_typespec ts;
 
-  if (mask->rank == 0 && mask->ts.kind != 4)
+  if (mask->rank == 0)
     {
-      gfc_typespec ts;
+      /* For the scalar case, coerce the mask to kind=4 unconditionally
+        (because this is the only kind we have a library function
+        for).  */
 
-      ts.type = BT_LOGICAL;
-      ts.kind = 4;
-      gfc_convert_type (mask, &ts, 2);
+      if (mask->ts.kind != 4)
+       {
+         ts.type = BT_LOGICAL;
+         ts.kind = 4;
+         gfc_convert_type (mask, &ts, 2);
+       }
+    }
+  else
+    {
+      /* In the library, we access the mask with a GFC_LOGICAL_1
+        argument.  No need to waste memory if we are about to create
+        a temporary array.  */
+      if (mask->expr_type == EXPR_OP)
+       {
+         ts.type = BT_LOGICAL;
+         ts.kind = 1;
+         gfc_convert_type (mask, &ts, 2);
+       }
     }
 }
 
@@ -118,8 +142,9 @@ gfc_resolve_access (gfc_expr *f, gfc_expr *name ATTRIBUTE_UNUSED,
 }
 
 
-void
-gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind)
+static void
+gfc_resolve_char_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind,
+                       const char *name)
 {
   f->ts.type = BT_CHARACTER;
   f->ts.kind = (kind == NULL)
@@ -129,13 +154,20 @@ gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind)
   gfc_current_ns->cl_list = f->ts.cl;
   f->ts.cl->length = gfc_int_expr (1);
 
-  f->value.function.name = gfc_get_string ("__achar_%d_%c%d", f->ts.kind,
+  f->value.function.name = gfc_get_string (name, f->ts.kind,
                                           gfc_type_letter (x->ts.type),
                                           x->ts.kind);
 }
 
 
 void
+gfc_resolve_achar (gfc_expr *f, gfc_expr *x, gfc_expr *kind)
+{
+  gfc_resolve_char_achar (f, x, kind, "__achar_%d_%c%d");
+}
+
+
+void
 gfc_resolve_acos (gfc_expr *f, gfc_expr *x)
 {
   f->ts = x->ts;
@@ -365,12 +397,7 @@ gfc_resolve_ceiling (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 void
 gfc_resolve_char (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
 {
-  f->ts.type = BT_CHARACTER;
-  f->ts.kind = (kind == NULL)
-            ? gfc_default_character_kind : mpz_get_si (kind->value.integer);
-  f->value.function.name
-    = gfc_get_string ("__char_%d_%c%d", f->ts.kind,
-                     gfc_type_letter (a->ts.type), a->ts.kind);
+  gfc_resolve_char_achar (f, a, kind, "__char_%d_%c%d");
 }
 
 
@@ -534,6 +561,9 @@ gfc_resolve_cshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
 {
   int n;
 
+  if (array->ts.type == BT_CHARACTER && array->ref)
+    gfc_resolve_substring_charlen (array);
+
   f->ts = array->ts;
   f->rank = array->rank;
   f->shape = gfc_copy_shape (array->shape, array->rank);
@@ -654,6 +684,9 @@ gfc_resolve_eoshift (gfc_expr *f, gfc_expr *array, gfc_expr *shift,
 {
   int n;
 
+  if (array->ts.type == BT_CHARACTER && array->ref)
+    gfc_resolve_substring_charlen (array);
+
   f->ts = array->ts;
   f->rank = array->rank;
   f->shape = gfc_copy_shape (array->shape, array->rank);
@@ -757,6 +790,15 @@ gfc_resolve_g77_math1 (gfc_expr *f, gfc_expr *x)
 
 
 void
+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);
+}
+
+
+void
 gfc_resolve_getcwd (gfc_expr *f, gfc_expr *n ATTRIBUTE_UNUSED)
 {
   f->ts.type = BT_INTEGER;
@@ -1114,6 +1156,15 @@ gfc_resolve_len_trim (gfc_expr *f, gfc_expr *string, gfc_expr *kind)
 
 
 void
+gfc_resolve_lgamma (gfc_expr *f, gfc_expr *x)
+{
+  f->ts = x->ts;
+  f->value.function.name
+    = gfc_get_string ("__lgamma_%d", x->ts.kind);
+}
+
+
+void
 gfc_resolve_link (gfc_expr *f, gfc_expr *p1 ATTRIBUTE_UNUSED,
                  gfc_expr *p2 ATTRIBUTE_UNUSED)
 {
@@ -1364,6 +1415,12 @@ gfc_resolve_merge (gfc_expr *f, gfc_expr *tsource,
                   gfc_expr *fsource ATTRIBUTE_UNUSED,
                   gfc_expr *mask ATTRIBUTE_UNUSED)
 {
+  if (tsource->ts.type == BT_CHARACTER && tsource->ref)
+    gfc_resolve_substring_charlen (tsource);
+
+  if (fsource->ts.type == BT_CHARACTER && fsource->ref)
+    gfc_resolve_substring_charlen (fsource);
+
   if (tsource->ts.type == BT_CHARACTER)
     check_charlen_present (tsource);
 
@@ -1572,6 +1629,9 @@ void
 gfc_resolve_pack (gfc_expr *f, gfc_expr *array, gfc_expr *mask,
                  gfc_expr *vector ATTRIBUTE_UNUSED)
 {
+  if (array->ts.type == BT_CHARACTER && array->ref)
+    gfc_resolve_substring_charlen (array);
+
   f->ts = array->ts;
   f->rank = 1;
 
@@ -1675,6 +1735,9 @@ gfc_resolve_reshape (gfc_expr *f, gfc_expr *source, gfc_expr *shape,
   int kind;
   int i;
 
+  if (source->ts.type == BT_CHARACTER && source->ref)
+    gfc_resolve_substring_charlen (source);
+
   f->ts = source->ts;
 
   gfc_array_size (shape, &rank);
@@ -1966,6 +2029,9 @@ void
 gfc_resolve_spread (gfc_expr *f, gfc_expr *source, gfc_expr *dim,
                    gfc_expr *ncopies)
 {
+  if (source->ts.type == BT_CHARACTER && source->ref)
+    gfc_resolve_substring_charlen (source);
+
   if (source->ts.type == BT_CHARACTER)
     check_charlen_present (source);
 
@@ -2217,6 +2283,9 @@ gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
   /* TODO: Make this do something meaningful.  */
   static char transfer0[] = "__transfer0", transfer1[] = "__transfer1";
 
+  if (mold->ts.type == BT_CHARACTER && !mold->ts.cl->length)
+    mold->ts.cl->length = gfc_int_expr (mold->value.character.length);
+
   f->ts = mold->ts;
 
   if (size == NULL && mold->rank == 0)
@@ -2240,6 +2309,10 @@ gfc_resolve_transfer (gfc_expr *f, gfc_expr *source ATTRIBUTE_UNUSED,
 void
 gfc_resolve_transpose (gfc_expr *f, gfc_expr *matrix)
 {
+
+  if (matrix->ts.type == BT_CHARACTER && matrix->ref)
+    gfc_resolve_substring_charlen (matrix);
+
   f->ts = matrix->ts;
   f->rank = 2;
   if (matrix->shape)
@@ -2366,6 +2439,9 @@ void
 gfc_resolve_unpack (gfc_expr *f, gfc_expr *vector, gfc_expr *mask,
                    gfc_expr *field ATTRIBUTE_UNUSED)
 {
+  if (vector->ts.type == BT_CHARACTER && vector->ref)
+    gfc_resolve_substring_charlen (vector);
+
   f->ts = vector->ts;
   f->rank = mask->rank;
   resolve_mask_arg (mask);
@@ -2657,9 +2733,18 @@ void
 gfc_resolve_getarg (gfc_code *c)
 {
   const char *name;
-  int kind;
-  kind = gfc_default_integer_kind;
-  name = gfc_get_string (PREFIX ("getarg_i%d"), kind);
+
+  if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind)
+    {
+      gfc_typespec ts;
+
+      ts.type = BT_INTEGER;
+      ts.kind = gfc_default_integer_kind;
+
+      gfc_convert_type (c->ext.actual->expr, &ts, 2);
+    }
+
+  name = gfc_get_string (PREFIX ("getarg_i%d"), gfc_default_integer_kind);
   c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
 }