Index: gcc/fortran/frontend-passes.c
===================================================================
*** gcc/fortran/frontend-passes.c	(revision 265262)
--- gcc/fortran/frontend-passes.c	(working copy)
*************** realloc_string_callback (gfc_code **c, i
*** 280,286 ****
  	   && (expr2->expr_type != EXPR_OP
  	       || expr2->value.op.op != INTRINSIC_CONCAT))
      return 0;
!   
    if (!gfc_check_dependency (expr1, expr2, true))
      return 0;
  
--- 280,286 ----
  	   && (expr2->expr_type != EXPR_OP
  	       || expr2->value.op.op != INTRINSIC_CONCAT))
      return 0;
! 
    if (!gfc_check_dependency (expr1, expr2, true))
      return 0;
  
*************** insert_block ()
*** 704,709 ****
--- 704,744 ----
    return ns;
  }
  
+ 
+ /* Insert a call to the intrinsic len. Use a different name for
+    the symbol tree so we don't run into trouble when the user has
+    renamed len for some reason.  */
+ 
+ static gfc_expr*
+ get_len_call (gfc_expr *str)
+ {
+   gfc_expr *fcn;
+   gfc_actual_arglist *actual_arglist;
+ 
+   fcn = gfc_get_expr ();
+   fcn->expr_type = EXPR_FUNCTION;
+   fcn->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LEN);
+   actual_arglist = gfc_get_actual_arglist ();
+   actual_arglist->expr = str;
+ 
+   fcn->value.function.actual = actual_arglist;
+   fcn->where = str->where;
+   fcn->ts.type = BT_INTEGER;
+   fcn->ts.kind = gfc_charlen_int_kind;
+ 
+   gfc_get_sym_tree ("__internal_len", current_ns, &fcn->symtree, false);
+   fcn->symtree->n.sym->ts = fcn->ts;
+   fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+   fcn->symtree->n.sym->attr.function = 1;
+   fcn->symtree->n.sym->attr.elemental = 1;
+   fcn->symtree->n.sym->attr.referenced = 1;
+   fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
+   gfc_commit_symbol (fcn->symtree->n.sym);
+ 
+   return fcn;
+ }
+ 
+ 
  /* Returns a new expression (a variable) to be used in place of the old one,
     with an optional assignment statement before the current statement to set
     the value of the variable. Creates a new BLOCK for the statement if that
*************** create_var (gfc_expr * e, const char *vn
*** 786,791 ****
--- 821,828 ----
        length = constant_string_length (e);
        if (length)
  	symbol->ts.u.cl->length = length;
+       else if (e->expr_type == EXPR_VARIABLE && e->ts.u.cl->length)
+ 	symbol->ts.u.cl->length = get_len_call (gfc_copy_expr (e));
        else
  	{
  	  symbol->attr.allocatable = 1;
*************** traverse_io_block (gfc_code *code, bool
*** 1226,1232 ****
  	    {
  	      /* Check for (a(i,i), i=1,3).  */
  	      int j;
! 	      
  	      for (j=0; j<i; j++)
  		if (iters[j] && iters[j]->var->symtree == start->symtree)
  		  return false;
--- 1263,1269 ----
  	    {
  	      /* Check for (a(i,i), i=1,3).  */
  	      int j;
! 
  	      for (j=0; j<i; j++)
  		if (iters[j] && iters[j]->var->symtree == start->symtree)
  		  return false;
*************** traverse_io_block (gfc_code *code, bool
*** 1286,1292 ****
  		      || var_in_expr (var, iters[j]->end)
  		      || var_in_expr (var, iters[j]->step)))
  		  return false;
! 	    }		  
  	}
      }
  
--- 1323,1329 ----
  		      || var_in_expr (var, iters[j]->end)
  		      || var_in_expr (var, iters[j]->step)))
  		  return false;
! 	    }
  	}
      }
  
*************** get_len_trim_call (gfc_expr *str, int ki
*** 2019,2024 ****
--- 2056,2062 ----
    return fcn;
  }
  
+ 
  /* Optimize expressions for equality.  */
  
  static bool
*************** do_subscript (gfc_expr **e)
*** 2626,2632 ****
  
  	      /* If we do not know about the stepsize, the loop may be zero trip.
  		 Do not warn in this case.  */
! 	  
  	      if (dl->ext.iterator->step->expr_type == EXPR_CONSTANT)
  		mpz_init_set (do_step, dl->ext.iterator->step->value.integer);
  	      else
--- 2664,2670 ----
  
  	      /* If we do not know about the stepsize, the loop may be zero trip.
  		 Do not warn in this case.  */
! 
  	      if (dl->ext.iterator->step->expr_type == EXPR_CONSTANT)
  		mpz_init_set (do_step, dl->ext.iterator->step->value.integer);
  	      else
*************** do_subscript (gfc_expr **e)
*** 2640,2646 ****
  	      else
  		have_do_start = false;
  
! 	  
  	      if (dl->ext.iterator->end->expr_type == EXPR_CONSTANT)
  		{
  		  have_do_end = true;
--- 2678,2684 ----
  	      else
  		have_do_start = false;
  
! 
  	      if (dl->ext.iterator->end->expr_type == EXPR_CONSTANT)
  		{
  		  have_do_end = true;
*************** matmul_to_var_expr (gfc_expr **ep, int *
*** 2806,2812 ****
  {
    gfc_expr *e, *n;
    bool *found = (bool *) data;
!   
    e = *ep;
  
    if (e->expr_type != EXPR_FUNCTION
--- 2844,2850 ----
  {
    gfc_expr *e, *n;
    bool *found = (bool *) data;
! 
    e = *ep;
  
    if (e->expr_type != EXPR_FUNCTION
*************** matmul_to_var_expr (gfc_expr **ep, int *
*** 2819,2837 ****
      return 0;
  
    /* Check if this is already in the form c = matmul(a,b).  */
!   
    if ((*current_code)->expr2 == e)
      return 0;
  
    n = create_var (e, "matmul");
!   
    /* If create_var is unable to create a variable (for example if
       -fno-realloc-lhs is in force with a variable that does not have bounds
       known at compile-time), just return.  */
  
    if (n == NULL)
      return 0;
!   
    *ep = n;
    *found = true;
    return 0;
--- 2857,2875 ----
      return 0;
  
    /* Check if this is already in the form c = matmul(a,b).  */
! 
    if ((*current_code)->expr2 == e)
      return 0;
  
    n = create_var (e, "matmul");
! 
    /* If create_var is unable to create a variable (for example if
       -fno-realloc-lhs is in force with a variable that does not have bounds
       known at compile-time), just return.  */
  
    if (n == NULL)
      return 0;
! 
    *ep = n;
    *found = true;
    return 0;
*************** matmul_to_var_code (gfc_code **c, int *w
*** 2850,2856 ****
        inserted_block = NULL;
        changed_statement = NULL;
      }
!   
    return 0;
  }
  
--- 2888,2894 ----
        inserted_block = NULL;
        changed_statement = NULL;
      }
! 
    return 0;
  }
  
*************** matmul_temp_args (gfc_code **c, int *wal
*** 2870,2876 ****
    bool a_tmp, b_tmp;
    gfc_expr *matrix_a, *matrix_b;
    bool conjg_a, conjg_b, transpose_a, transpose_b;
!   
    co = *c;
  
    if (co->op != EXEC_ASSIGN)
--- 2908,2914 ----
    bool a_tmp, b_tmp;
    gfc_expr *matrix_a, *matrix_b;
    bool conjg_a, conjg_b, transpose_a, transpose_b;
! 
    co = *c;
  
    if (co->op != EXEC_ASSIGN)
*************** matmul_temp_args (gfc_code **c, int *wal
*** 2920,2926 ****
  
    if (!a_tmp && !b_tmp)
      return 0;
!   
    current_code = c;
    inserted_block = NULL;
    changed_statement = NULL;
--- 2958,2964 ----
  
    if (!a_tmp && !b_tmp)
      return 0;
! 
    current_code = c;
    inserted_block = NULL;
    changed_statement = NULL;
*************** scalarized_expr (gfc_expr *e_in, gfc_exp
*** 3648,3654 ****
  		      /* For assumed size, we need to keep around the final
  			 reference in order not to get an error on resolution
  			 below, and we cannot use AR_FULL.  */
! 			 
  		      if (ar->as->type == AS_ASSUMED_SIZE)
  			{
  			  ar->type = AR_SECTION;
--- 3686,3692 ----
  		      /* For assumed size, we need to keep around the final
  			 reference in order not to get an error on resolution
  			 below, and we cannot use AR_FULL.  */
! 
  		      if (ar->as->type == AS_ASSUMED_SIZE)
  			{
  			  ar->type = AR_SECTION;
*************** call_external_blas (gfc_code **c, int *w
*** 4604,4610 ****
  	default:
  	  gcc_unreachable ();
  	}
!     }    
  
    /* Handle the reallocation, if needed.  */
  
--- 4642,4648 ----
  	default:
  	  gcc_unreachable ();
  	}
!     }
  
    /* Handle the reallocation, if needed.  */
  
*************** typedef struct {
*** 4756,4762 ****
    int n[GFC_MAX_DIMENSIONS];
  } ind_type;
  
! /* Callback function to determine if an expression is the 
     corresponding variable.  */
  
  static int
--- 4794,4800 ----
    int n[GFC_MAX_DIMENSIONS];
  } ind_type;
  
! /* Callback function to determine if an expression is the
     corresponding variable.  */
  
  static int
*************** index_interchange (gfc_code **c, int *wa
*** 4842,4848 ****
    gfc_forall_iterator *fa;
    ind_type *ind;
    int i, j;
!   
    if (co->op != EXEC_FORALL && co->op != EXEC_DO_CONCURRENT)
      return 0;
  
--- 4880,4886 ----
    gfc_forall_iterator *fa;
    ind_type *ind;
    int i, j;
! 
    if (co->op != EXEC_FORALL && co->op != EXEC_DO_CONCURRENT)
      return 0;
  
*************** gfc_code_walker (gfc_code **c, walk_code
*** 5358,5364 ****
  
  	  if (co->op == EXEC_SELECT)
  	    select_level --;
!   
  	  in_omp_workshare = saved_in_omp_workshare;
  	  in_where = saved_in_where;
  	}
--- 5396,5402 ----
  
  	  if (co->op == EXEC_SELECT)
  	    select_level --;
! 
  	  in_omp_workshare = saved_in_omp_workshare;
  	  in_where = saved_in_where;
  	}
Index: gcc/testsuite/gfortran.dg/deferred_character_23.f90
===================================================================
*** gcc/testsuite/gfortran.dg/deferred_character_23.f90	(revision 265262)
--- gcc/testsuite/gfortran.dg/deferred_character_23.f90	(working copy)
*************** program strlen_bug
*** 15,22 ****
        'somewhat longer' ]
    maxlen = maxval (len_trim (strings))
    if (maxlen .ne. 15) stop 1
!   strings = strings(:)(:maxlen) ! Used to ICE
!   if (any (strings .ne. ['short          ','somewhat longer'])) stop 2
  
    deallocate (strings)          ! To check for memory leaks
  end program
--- 15,30 ----
        'somewhat longer' ]
    maxlen = maxval (len_trim (strings))
    if (maxlen .ne. 15) stop 1
! 
! ! Used to cause an ICE and in the later version of the problem did not reallocate.
!   strings = strings(:)(:maxlen)
!   if (any (strings .ne. ['short          ','somewhat longer' ])) stop 2
!   if (len (strings) .ne. maxlen) stop 3
! 
! ! Try something a bit more complicated.
!   strings = strings(:)(2:maxlen - 5)
!   if (any (strings .ne. ['hort     ','omewhat l' ])) stop 4
!   if (len (strings) .ne. maxlen - 6) stop 5
  
    deallocate (strings)          ! To check for memory leaks
  end program