re PR fortran/31879 (ICE with function having array of character variables argument)
authorPaul Thomas <pault@gcc.gnu.org>
Thu, 30 Aug 2007 22:10:55 +0000 (22:10 +0000)
committerPaul Thomas <pault@gcc.gnu.org>
Thu, 30 Aug 2007 22:10:55 +0000 (22:10 +0000)
2007-08-31  Paul Thomas  <pault@gcc.gnu.org>

PR fortran/31879
PR fortran/31197
PR fortran/31258
PR fortran/32703
* gfortran.h : Add prototype for gfc_resolve_substring_charlen.
* resolve.c (gfc_resolve_substring_charlen): New function.
(resolve_ref): Call gfc_resolve_substring_charlen.
(gfc_resolve_character_operator): New function.
(gfc_resolve_expr): Call the new functions in cases where the
character length is missing.
* iresolve.c (cshift, eoshift, merge, pack, reshape, spread,
transpose, unpack): Call gfc_resolve_substring_charlen for
source expressions that are character and have a reference.
* trans.h (gfc_trans_init_string_length) Change name to
gfc_conv_string_length; modify references in trans-expr.c,
trans-array.c and trans-decl.c.
* trans-expr.c (gfc_trans_string_length): Handle case of no
backend_decl.
(gfc_conv_aliased_arg): Remove code for treating substrings
and replace with call to gfc_trans_string_length.
* trans-array.c (gfc_conv_expr_descriptor): Remove code for
treating strings and call gfc_trans_string_length instead.

2007-08-31  Paul Thomas  <pault@gcc.gnu.org>

PR fortran/31879
* gfortran.dg/char_length_7.f90: New test.
* gfortran.dg/char_length_9.f90: New test.
* gfortran.dg/char_assign_1.f90: Add extra warning.

PR fortran/31197
PR fortran/31258
* gfortran.dg/char_length_8.f90: New test.

From-SVN: r127939

13 files changed:
gcc/fortran/ChangeLog
gcc/fortran/gfortran.h
gcc/fortran/iresolve.c
gcc/fortran/resolve.c
gcc/fortran/trans-array.c
gcc/fortran/trans-decl.c
gcc/fortran/trans-expr.c
gcc/fortran/trans.h
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/char_assign_1.f90
gcc/testsuite/gfortran.dg/char_length_7.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/char_length_8.f90 [new file with mode: 0644]
gcc/testsuite/gfortran.dg/char_length_9.f90 [new file with mode: 0644]

index e40c9e233ff44d496a504e243a3f2183d555007e..ecbb76776fd6f2acbcd4974fbfaa37ff314f12c1 100644 (file)
@@ -1,3 +1,28 @@
+2007-08-31  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/31879
+       PR fortran/31197
+       PR fortran/31258
+       PR fortran/32703
+       * gfortran.h : Add prototype for gfc_resolve_substring_charlen.
+       * resolve.c (gfc_resolve_substring_charlen): New function.
+       (resolve_ref): Call gfc_resolve_substring_charlen.
+       (gfc_resolve_character_operator): New function.
+       (gfc_resolve_expr): Call the new functions in cases where the
+       character length is missing.
+       * iresolve.c (cshift, eoshift, merge, pack, reshape, spread,
+       transpose, unpack): Call gfc_resolve_substring_charlen for
+       source expressions that are character and have a reference.
+       * trans.h (gfc_trans_init_string_length) Change name to
+       gfc_conv_string_length; modify references in trans-expr.c,
+       trans-array.c and trans-decl.c.
+       * trans-expr.c (gfc_trans_string_length): Handle case of no
+       backend_decl.
+       (gfc_conv_aliased_arg): Remove code for treating substrings
+       and replace with call to gfc_trans_string_length.
+       * trans-array.c (gfc_conv_expr_descriptor): Remove code for
+       treating strings and call gfc_trans_string_length instead.
+
 2007-08-30  Tobias Burnus  <burnus@net-b.de>
 
        PR fortran/33228
index 358055ae490ffb22bafbd4624579aba6baf2d8c6..5c8c56dd6adbaf146b70b8408f1afc9c7078c9db 100644 (file)
@@ -2267,6 +2267,7 @@ try gfc_resolve_iterator (gfc_iterator *, bool);
 try gfc_resolve_index (gfc_expr *, int);
 try gfc_resolve_dim_arg (gfc_expr *);
 int gfc_is_formal_arg (void);
+void gfc_resolve_substring_charlen (gfc_expr *);
 match gfc_iso_c_sub_interface(gfc_code *, gfc_symbol *);
 
 
index 73f5d73bc455b1f141722d078e4bc93650b0e151..38da76be71aed0daf4e036f5dd85f67b1a16b375 100644 (file)
@@ -534,6 +534,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 +657,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);
@@ -1382,6 +1388,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);
 
@@ -1590,6 +1602,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;
 
@@ -1693,6 +1708,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);
@@ -1984,6 +2002,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);
 
@@ -2258,6 +2279,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)
@@ -2384,6 +2409,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);
index 4610c08d1995820d16a4fea4673a82f3ea625a95..424acfc68298d94123817de426c98672109c8063 100644 (file)
@@ -3535,6 +3535,70 @@ resolve_substring (gfc_ref *ref)
 }
 
 
+/* This function supplies missing substring charlens.  */
+
+void
+gfc_resolve_substring_charlen (gfc_expr *e)
+{
+  gfc_ref *char_ref;
+  gfc_expr *start, *end;
+
+  for (char_ref = e->ref; char_ref; char_ref = char_ref->next)
+    if (char_ref->type == REF_SUBSTRING)
+      break;
+
+  if (!char_ref)
+    return;
+
+  gcc_assert (char_ref->next == NULL);
+
+  if (e->ts.cl)
+    {
+      if (e->ts.cl->length)
+       gfc_free_expr (e->ts.cl->length);
+      else if (e->expr_type == EXPR_VARIABLE
+                && e->symtree->n.sym->attr.dummy)
+       return;
+    }
+
+  e->ts.type = BT_CHARACTER;
+  e->ts.kind = gfc_default_character_kind;
+
+  if (!e->ts.cl)
+    {
+      e->ts.cl = gfc_get_charlen ();
+      e->ts.cl->next = gfc_current_ns->cl_list;
+      gfc_current_ns->cl_list = e->ts.cl;
+    }
+
+  if (char_ref->u.ss.start)
+    start = gfc_copy_expr (char_ref->u.ss.start);
+  else
+    start = gfc_int_expr (1);
+
+  if (char_ref->u.ss.end)
+    end = gfc_copy_expr (char_ref->u.ss.end);
+  else if (e->expr_type == EXPR_VARIABLE)
+    end = gfc_copy_expr (e->symtree->n.sym->ts.cl->length);
+  else
+    end = NULL;
+
+  if (!start || !end)
+    return;
+
+  /* Length = (end - start +1).  */
+  e->ts.cl->length = gfc_subtract (end, start);
+  e->ts.cl->length = gfc_add (e->ts.cl->length, gfc_int_expr (1));
+
+  e->ts.cl->length->ts.type = BT_INTEGER;
+  e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
+
+  /* Make sure that the length is simplified.  */
+  gfc_simplify_expr (e->ts.cl->length, 1);
+  gfc_resolve_expr (e->ts.cl->length);
+}
+
+
 /* Resolve subtype references.  */
 
 static try
@@ -3908,6 +3972,78 @@ check_host_association (gfc_expr *e)
 }
 
 
+static void
+gfc_resolve_character_operator (gfc_expr *e)
+{
+  gfc_expr *op1 = e->value.op.op1;
+  gfc_expr *op2 = e->value.op.op2;
+  gfc_expr *e1 = NULL;
+  gfc_expr *e2 = NULL;
+
+  gcc_assert (e->value.op.operator == INTRINSIC_CONCAT);
+
+  if (op1->ts.cl && op1->ts.cl->length)
+    e1 = gfc_copy_expr (op1->ts.cl->length);
+  else if (op1->expr_type == EXPR_CONSTANT)
+    e1 = gfc_int_expr (op1->value.character.length);
+
+  if (op2->ts.cl && op2->ts.cl->length)
+    e2 = gfc_copy_expr (op2->ts.cl->length);
+  else if (op2->expr_type == EXPR_CONSTANT)
+    e2 = gfc_int_expr (op2->value.character.length);
+
+  e->ts.cl = gfc_get_charlen ();
+  e->ts.cl->next = gfc_current_ns->cl_list;
+  gfc_current_ns->cl_list = e->ts.cl;
+
+  if (!e1 || !e2)
+    return;
+
+  e->ts.cl->length = gfc_add (e1, e2);
+  e->ts.cl->length->ts.type = BT_INTEGER;
+  e->ts.cl->length->ts.kind = gfc_charlen_int_kind;;
+  gfc_simplify_expr (e->ts.cl->length, 0);
+  gfc_resolve_expr (e->ts.cl->length);
+
+  return;
+}
+
+
+/*  Ensure that an character expression has a charlen and, if possible, a
+    length expression.  */
+
+static void
+fixup_charlen (gfc_expr *e)
+{
+  /* The cases fall through so that changes in expression type and the need
+     for multiple fixes are picked up.  In all circumstances, a charlen should
+     be available for the middle end to hang a backend_decl on.  */
+  switch (e->expr_type)
+    {
+    case EXPR_OP:
+      gfc_resolve_character_operator (e);
+
+    case EXPR_ARRAY:
+      if (e->expr_type == EXPR_ARRAY)
+       gfc_resolve_character_array_constructor (e);
+
+    case EXPR_SUBSTRING:
+      if (!e->ts.cl && e->ref)
+       gfc_resolve_substring_charlen (e);
+
+    default:
+      if (!e->ts.cl)
+       {
+         e->ts.cl = gfc_get_charlen ();
+         e->ts.cl->next = gfc_current_ns->cl_list;
+         gfc_current_ns->cl_list = e->ts.cl;
+       }
+
+      break;
+    }
+}
+
+
 /* Resolve an expression.  That is, make sure that types of operands agree
    with their operators, intrinsic operators are converted to function calls
    for overloaded types and unresolved function references are resolved.  */
@@ -3937,6 +4073,11 @@ gfc_resolve_expr (gfc_expr *e)
          if (t == SUCCESS)
            expression_rank (e);
        }
+
+      if (e->ts.type == BT_CHARACTER && e->ts.cl == NULL && e->ref
+           && e->ref->type != REF_SUBSTRING)
+       gfc_resolve_substring_charlen (e);
+
       break;
 
     case EXPR_SUBSTRING:
@@ -3985,6 +4126,9 @@ gfc_resolve_expr (gfc_expr *e)
       gfc_internal_error ("gfc_resolve_expr(): Bad expression type");
     }
 
+  if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.cl)
+    fixup_charlen (e);
+
   return t;
 }
 
index 09d20cd42913905ef7c96a03001c3bd570bb230d..69be8efb2f30a2613500012435428ba502bfac9a 100644 (file)
@@ -1375,7 +1375,7 @@ get_array_ctor_all_strlen (stmtblock_t *block, gfc_expr *e, tree *len)
   if (*len && INTEGER_CST_P (*len))
     return;
 
-  if (!e->ref && e->ts.cl->length
+  if (!e->ref && e->ts.cl && e->ts.cl->length
        && e->ts.cl->length->expr_type == EXPR_CONSTANT)
     {
       /* This is easy.  */
@@ -1639,17 +1639,6 @@ gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss)
       if (!ss->string_length)
        gfc_todo_error ("complex character array constructors");
 
-      /* It is surprising but still possible to wind up with expressions that
-        lack a character length.
-        TODO Find the offending part of the front end and cure this properly.
-        Concatenation involving arrays is the main culprit.  */
-      if (!ss->expr->ts.cl)
-       {
-         ss->expr->ts.cl = gfc_get_charlen ();
-         ss->expr->ts.cl->next = gfc_current_ns->cl_list;
-         gfc_current_ns->cl_list = ss->expr->ts.cl->next;
-       }
-
       ss->expr->ts.cl->backend_decl = ss->string_length;
 
       type = gfc_get_character_type_len (ss->expr->ts.kind, ss->string_length);
@@ -3909,7 +3898,7 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
   if (sym->ts.type == BT_CHARACTER
       && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
     {
-      gfc_trans_init_string_length (sym->ts.cl, &block);
+      gfc_conv_string_length (sym->ts.cl, &block);
 
       gfc_trans_vla_type_sizes (sym, &block);
 
@@ -3933,7 +3922,7 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
 
   if (sym->ts.type == BT_CHARACTER
       && !INTEGER_CST_P (sym->ts.cl->backend_decl))
-    gfc_trans_init_string_length (sym->ts.cl, &block);
+    gfc_conv_string_length (sym->ts.cl, &block);
 
   size = gfc_trans_array_bounds (type, sym, &offset, &block);
 
@@ -3999,7 +3988,7 @@ gfc_trans_g77_array (gfc_symbol * sym, tree body)
 
   if (sym->ts.type == BT_CHARACTER
       && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
-    gfc_trans_init_string_length (sym->ts.cl, &block);
+    gfc_conv_string_length (sym->ts.cl, &block);
 
   /* Evaluate the bounds of the array.  */
   gfc_trans_array_bounds (type, sym, &offset, &block);
@@ -4091,7 +4080,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
 
   if (sym->ts.type == BT_CHARACTER
       && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
-    gfc_trans_init_string_length (sym->ts.cl, &block);
+    gfc_conv_string_length (sym->ts.cl, &block);
 
   checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
 
@@ -4530,63 +4519,18 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
       loop.temp_ss = gfc_get_ss ();
       loop.temp_ss->type = GFC_SS_TEMP;
       loop.temp_ss->next = gfc_ss_terminator;
+
+      if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
+       gfc_conv_string_length (expr->ts.cl, &se->pre);
+
+      loop.temp_ss->data.temp.type = gfc_typenode_for_spec (&expr->ts);
+
       if (expr->ts.type == BT_CHARACTER)
-       {
-         if (expr->ts.cl == NULL)
-           {
-             /* This had better be a substring reference!  */
-             gfc_ref *char_ref = expr->ref;
-             for (; char_ref; char_ref = char_ref->next)
-               if (char_ref->type == REF_SUBSTRING)
-                 {
-                   mpz_t char_len;
-                   expr->ts.cl = gfc_get_charlen ();
-                   expr->ts.cl->next = char_ref->u.ss.length->next;
-                   char_ref->u.ss.length->next = expr->ts.cl;
-
-                   mpz_init_set_ui (char_len, 1);
-                   mpz_add (char_len, char_len,
-                            char_ref->u.ss.end->value.integer);
-                   mpz_sub (char_len, char_len,
-                            char_ref->u.ss.start->value.integer);
-                   expr->ts.cl->backend_decl
-                       = gfc_conv_mpz_to_tree (char_len,
-                                       gfc_default_character_kind);
-                   /* Cast is necessary for *-charlen refs.  */
-                   expr->ts.cl->backend_decl
-                       = convert (gfc_charlen_type_node,
-                                  expr->ts.cl->backend_decl);
-                   mpz_clear (char_len);
-                     break;
-                 }
-             gcc_assert (char_ref != NULL);
-             loop.temp_ss->data.temp.type
-               = gfc_typenode_for_spec (&expr->ts);
-             loop.temp_ss->string_length = expr->ts.cl->backend_decl;
-           }
-         else if (expr->ts.cl->length
-                    && expr->ts.cl->length->expr_type == EXPR_CONSTANT)
-           {
-             gfc_conv_const_charlen (expr->ts.cl);
-             loop.temp_ss->data.temp.type
-               = gfc_typenode_for_spec (&expr->ts);
-             loop.temp_ss->string_length
-               = TYPE_SIZE_UNIT (loop.temp_ss->data.temp.type);
-           }
-         else
-           {
-             loop.temp_ss->data.temp.type
-               = gfc_typenode_for_spec (&expr->ts);
-             loop.temp_ss->string_length = expr->ts.cl->backend_decl;
-           }
-         se->string_length = loop.temp_ss->string_length;
-       }
+       loop.temp_ss->string_length = expr->ts.cl->backend_decl;
       else
-       {
-         loop.temp_ss->data.temp.type
-           = gfc_typenode_for_spec (&expr->ts);
-         loop.temp_ss->string_length = NULL;
-       }
+       loop.temp_ss->string_length = NULL;
+
+      se->string_length = loop.temp_ss->string_length;
       loop.temp_ss->data.temp.dimen = loop.dimen;
       gfc_add_ss_to_loop (&loop, loop.temp_ss);
     }
@@ -5318,7 +5262,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body)
   if (sym->ts.type == BT_CHARACTER
       && !INTEGER_CST_P (sym->ts.cl->backend_decl))
     {
-      gfc_trans_init_string_length (sym->ts.cl, &fnblock);
+      gfc_conv_string_length (sym->ts.cl, &fnblock);
       gfc_trans_vla_type_sizes (sym, &fnblock);
     }
 
index 8ea25fc253290ff5495ce0937a6701ed6fdf39d6..109a18707b4c4945a99c8e03ff824370dc1c8acd 100644 (file)
@@ -2374,7 +2374,7 @@ gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
   gfc_start_block (&body);
 
   /* Evaluate the string length expression.  */
-  gfc_trans_init_string_length (cl, &body);
+  gfc_conv_string_length (cl, &body);
 
   gfc_trans_vla_type_sizes (sym, &body);
 
@@ -2398,7 +2398,7 @@ gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
   gfc_start_block (&body);
 
   /* Evaluate the string length expression.  */
-  gfc_trans_init_string_length (sym->ts.cl, &body);
+  gfc_conv_string_length (sym->ts.cl, &body);
 
   gfc_trans_vla_type_sizes (sym, &body);
 
index 02bd91d286095c200440457ae3b04cbac33044b3..99f180a1771b289fb21bb7f833de4bcc9fc22c21 100644 (file)
@@ -220,10 +220,9 @@ gfc_get_expr_charlen (gfc_expr *e)
    value.  */
 
 void
-gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock)
+gfc_conv_string_length (gfc_charlen * cl, stmtblock_t * pblock)
 {
   gfc_se se;
-  tree tmp;
 
   gfc_init_se (&se, NULL);
   gfc_conv_expr_type (&se, cl->length, gfc_charlen_type_node);
@@ -231,8 +230,10 @@ gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock)
                         build_int_cst (gfc_charlen_type_node, 0));
   gfc_add_block_to_block (pblock, &se.pre);
 
-  tmp = cl->backend_decl;
-  gfc_add_modify_expr (pblock, tmp, se.expr);
+  if (cl->backend_decl)
+    gfc_add_modify_expr (pblock, cl->backend_decl, se.expr);
+  else
+    cl->backend_decl = gfc_evaluate_now (se.expr, pblock);
 }
 
 
@@ -1823,6 +1824,9 @@ gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
   gfc_conv_ss_startstride (&loop);
 
   /* Build an ss for the temporary.  */
+  if (expr->ts.type == BT_CHARACTER && !expr->ts.cl->backend_decl)
+    gfc_conv_string_length (expr->ts.cl, &parmse->pre);
+
   base_type = gfc_typenode_for_spec (&expr->ts);
   if (GFC_ARRAY_TYPE_P (base_type)
                || GFC_DESCRIPTOR_TYPE_P (base_type))
@@ -1833,39 +1837,11 @@ gfc_conv_aliased_arg (gfc_se * parmse, gfc_expr * expr,
   loop.temp_ss->data.temp.type = base_type;
 
   if (expr->ts.type == BT_CHARACTER)
-    {
-      gfc_ref *char_ref = expr->ref;
-
-      for (; char_ref; char_ref = char_ref->next)
-       if (char_ref->type == REF_SUBSTRING)
-         {
-           gfc_se tmp_se;
-
-           expr->ts.cl = gfc_get_charlen ();
-           expr->ts.cl->next = char_ref->u.ss.length->next;
-           char_ref->u.ss.length->next = expr->ts.cl;
-
-           gfc_init_se (&tmp_se, NULL);
-           gfc_conv_expr_type (&tmp_se, char_ref->u.ss.end,
-                               gfc_array_index_type);
-           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
-                              tmp_se.expr, gfc_index_one_node);
-           tmp = gfc_evaluate_now (tmp, &parmse->pre);
-           gfc_init_se (&tmp_se, NULL);
-           gfc_conv_expr_type (&tmp_se, char_ref->u.ss.start,
-                               gfc_array_index_type);
-           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
-                              tmp, tmp_se.expr);
-           tmp = fold_convert (gfc_charlen_type_node, tmp);
-           expr->ts.cl->backend_decl = tmp;
-
-           break;
-         }
-      loop.temp_ss->data.temp.type
-               = gfc_typenode_for_spec (&expr->ts);
-      loop.temp_ss->string_length = expr->ts.cl->backend_decl;
-    }
+    loop.temp_ss->string_length = expr->ts.cl->backend_decl;
+  else
+    loop.temp_ss->string_length = NULL;
 
+  parmse->string_length = loop.temp_ss->string_length;
   loop.temp_ss->data.temp.dimen = loop.dimen;
   loop.temp_ss->next = gfc_ss_terminator;
 
index 1991748eccc53d7ce14a109b271bcf5b0701c8c7..389d0378ff057059028eda2ad3b6c24848918e84 100644 (file)
@@ -340,7 +340,7 @@ tree gfc_conv_string_tmp (gfc_se *, tree, tree);
 /* Get the string length variable belonging to an expression.  */
 tree gfc_get_expr_charlen (gfc_expr *);
 /* Initialize a string length variable.  */
-void gfc_trans_init_string_length (gfc_charlen *, stmtblock_t *);
+void gfc_conv_string_length (gfc_charlen *, stmtblock_t *);
 /* Ensure type sizes can be gimplified.  */
 void gfc_trans_vla_type_sizes (gfc_symbol *, stmtblock_t *);
 
index 1274ef11e0d4fee4891661ce3de3362a9e4966b5..cb25b9615f70532cd1760ccb8a8f00b683b5bc0a 100644 (file)
@@ -1,3 +1,14 @@
+2007-08-31  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/31879
+       * gfortran.dg/char_length_7.f90: New test.
+       * gfortran.dg/char_length_9.f90: New test.
+       * gfortran.dg/char_assign_1.f90: Add extra warning.
+
+       PR fortran/31197
+       PR fortran/31258
+       * gfortran.dg/char_length_8.f90: New test.
+
 2007-08-30  Andrew Pinski  <andrew_pinski@playstation.sony.com>
 
        * gcc.target/powerpc/ppu-intrinsics.c: New testcase.
index f2f36501e5159ab7a0be4d277761ea574eadb26c..0d31cee7a1531aca0f524e3b930b33b1b3481de1 100644 (file)
@@ -11,7 +11,7 @@ character(len=2), dimension(5) :: p
 character(len=3), dimension(5) :: q
 
 y(:)%c = "abcdef" ! { dg-warning "in assignment \\(5/6\\)" }
-p(1) = y(1)%c(3:)
+p(1) = y(1)%c(3:) ! { dg-warning "in assignment \\(2/3\\)" }
 if (p(1).ne."cd") call abort()
 
 p(1) = y(1)%c  ! { dg-warning "in assignment \\(2/5\\)" }
diff --git a/gcc/testsuite/gfortran.dg/char_length_7.f90 b/gcc/testsuite/gfortran.dg/char_length_7.f90
new file mode 100644 (file)
index 0000000..221c840
--- /dev/null
@@ -0,0 +1,32 @@
+! { dg-do run }
+! Test the fix for PR31879 in which the concatenation operators below
+! would cause ICEs because the character lengths were never resolved.
+!
+! Contributed by Vivek Rao <vivekrao4@yahoo.com> 
+!
+module str_mod
+  character(3) :: mz(2) = (/"fgh","ijk"/)
+contains
+  function ccopy(yy) result(xy)
+    character (len=*), intent(in) :: yy(:)
+    character (len=5) :: xy(size(yy))
+    xy = yy
+  end function ccopy
+end module str_mod
+!
+program xx
+  use str_mod, only: ccopy, mz
+  implicit none
+  character(2) :: z = "zz"
+  character(3) :: zz(2) = (/"abc","cde"/)
+  character(2) :: ans(2)
+  integer :: i = 2, j = 3
+  if (any(ccopy("_&_"//(/"A","B"/)//"?") .ne. (/"_&_A?","_&_B?"/))) call abort ()
+  if (any(ccopy(z//zz) .ne. (/"zzabc","zzcde"/))) call abort ()
+  if (any(ccopy(z//zz(:)(1:2)) .ne. (/"zzab ","zzcd "/))) call abort ()
+  if (any(ccopy(z//mz(:)(2:3)) .ne. (/"zzgh ","zzjk "/))) call abort ()
+
+! This was another bug, uncovered when the PR was fixed.
+  if (any(ccopy(z//mz(:)(i:j)) .ne. (/"zzgh ","zzjk "/))) call abort ()
+end program xx
+! { dg-final { cleanup-modules "str_mod" } }
diff --git a/gcc/testsuite/gfortran.dg/char_length_8.f90 b/gcc/testsuite/gfortran.dg/char_length_8.f90
new file mode 100644 (file)
index 0000000..dd91de3
--- /dev/null
@@ -0,0 +1,69 @@
+! { dg-do run }
+! Test the fix for PR31197 and PR31258 in which the substrings below
+! would cause ICEs because the character lengths were never resolved.
+!
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk> 
+!            and Thomas Koenig <tkoenig@gcc.gnu.org>
+!
+  CHARACTER(LEN=3), DIMENSION(10) :: Z
+  CHARACTER(LEN=3), DIMENSION(3,3) :: W
+  integer :: ctr = 0
+  call test_reshape
+  call test_eoshift
+  call test_cshift
+  call test_spread
+  call test_transpose
+  call test_pack
+  call test_unpack
+  call test_pr31197
+  if (ctr .ne. 8) call abort
+contains
+  subroutine test_reshape 
+    Z(:)="123"
+    if (any (RESHAPE(Z(:)(2:2),(/5,2/)) .ne. "2")) call abort 
+    ctr = ctr + 1
+  end subroutine
+  subroutine test_eoshift 
+    CHARACTER(LEN=1), DIMENSION(10) :: chk
+    chk(1:8) = "5"
+    chk(9:10) = " "
+    Z(:)="456"
+    if (any (EOSHIFT(Z(:)(2:2),2) .ne. chk)) call abort 
+    ctr = ctr + 1
+  END subroutine
+  subroutine test_cshift 
+    Z(:)="901"
+    if (any (CSHIFT(Z(:)(2:2),2) .ne. "0")) call abort 
+    ctr = ctr + 1
+  end subroutine
+  subroutine test_spread 
+    Z(:)="789"
+    if (any (SPREAD(Z(:)(2:2),dim=1,ncopies=2) .ne. "8")) call abort 
+    ctr = ctr + 1
+  end subroutine
+  subroutine test_transpose 
+    W(:, :)="abc"
+    if (any (TRANSPOSE(W(:,:)(1:2)) .ne. "ab")) call abort 
+    ctr = ctr + 1
+  end subroutine
+  subroutine test_pack 
+    W(:, :)="def"
+    if (any (pack(W(:,:)(2:3),mask=.true.) .ne. "ef")) call abort 
+    ctr = ctr + 1
+  end subroutine
+  subroutine test_unpack 
+    logical, dimension(5,2) :: mask
+    Z(:)="hij"
+    mask = .true.
+    if (any (unpack(Z(:)(2:2),mask,' ') .ne. "i")) call abort 
+    ctr = ctr + 1
+  end subroutine
+  subroutine test_pr31197
+    TYPE data
+      CHARACTER(LEN=3) :: A = "xyz"
+    END TYPE
+    TYPE(data), DIMENSION(10), TARGET :: T
+    if (any (TRANSPOSE(RESHAPE(T(:)%A(2:2),(/5,2/))) .ne. "y")) call abort 
+    ctr = ctr + 1
+  end subroutine
+END
diff --git a/gcc/testsuite/gfortran.dg/char_length_9.f90 b/gcc/testsuite/gfortran.dg/char_length_9.f90
new file mode 100644 (file)
index 0000000..dbec68c
--- /dev/null
@@ -0,0 +1,22 @@
+! { dg-do compile }
+! Test the fix for a regression caused by the first fix of PR31879.
+! Reported by Tobias Burnus <burnus@gcc.gnu.org>
+!
+MODULE input_val_types
+  IMPLICIT NONE
+  INTEGER, PARAMETER :: default_string_length=80
+  TYPE val_type
+    CHARACTER(len=default_string_length), DIMENSION(:), POINTER :: c_val
+  END TYPE val_type
+CONTAINS
+  SUBROUTINE val_get (val, c_val)
+    TYPE(val_type), POINTER                  :: val
+    CHARACTER(LEN=*), INTENT(out)            :: c_val
+    INTEGER                                  :: i, l_out
+    i=1
+    c_val((i-1)*default_string_length+1:MIN (l_out, i*default_string_length)) = &
+               val%c_val(i)(1:MIN (80, l_out-(i-1)*default_string_length))
+  END SUBROUTINE val_get
+END MODULE input_val_types
+
+! { dg-final { cleanup-modules "input_val_types" } }