re PR fortran/47674 (gfortran.dg/realloc_on_assign_5.f03: Segfault at run time…

re PR fortran/47674 (gfortran.dg/realloc_on_assign_5.f03: Segfault at run time for deferred (allocatable) string length)

2015-01-05  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/47674
	* dependency.c:  Update copyright years.
	(gfc_discard_nops):  Add prototype.
	* dependency.c (discard_nops):  Rename to gfc_discard_nops,
	make non-static.
	(gfc_discard_nops):  Use gfc_discard_nops.
	(gfc_dep_difference):  Likewise.
	* frontend-passes.c  Update copyright years.
	(realloc_strings):  New function.  Add prototype.
	(gfc_run_passes):  Call realloc_strings.
	(realloc_string_callback):  New function.
	(create_var):  Add prototype.  Handle case of a
	scalar character variable.
	(optimize_trim):  Do not handle allocatable variables.

2015-01-05  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/47674
	* gfortran.dg/realloc_on_assign_25.f90:  New test.

From-SVN: r219193

gcc/fortran/ChangeLog

+2015-01-05  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/47674
+	* dependency.c:  Update copyright years.
+	(gfc_discard_nops):  Add prototype.
+	* dependency.c (discard_nops):  Rename to gfc_discard_nops,
+	make non-static.
+	(gfc_discard_nops):  Use gfc_discard_nops.
+	(gfc_dep_difference):  Likewise.
+	* frontend-passes.c  Update copyright years.
+	(realloc_strings):  New function.  Add prototype.
+	(gfc_run_passes):  Call realloc_strings.
+	(realloc_string_callback):  New function.
+	(create_var):  Add prototype.  Handle case of a
+	scalar character variable.
+	(optimize_trim):  Do not handle allocatable variables.
+
 2015-01-05  Jakub Jelinek  <jakub@redhat.com>
 
 	Update copyright years.

gcc/fortran/dependency.c

@@ -243,8 +243,8 @@ gfc_dep_compare_functions (gfc_expr *e1, gfc_expr *e2, bool impure_ok)
 /* Helper function to look through parens, unary plus and widening
    integer conversions.  */
 
-static gfc_expr*
-discard_nops (gfc_expr *e)
+gfc_expr *
+gfc_discard_nops (gfc_expr *e)
 {
   gfc_actual_arglist *arglist;
 
@@ -297,8 +297,8 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
   if (e1 == NULL && e2 == NULL)
     return 0;
 
-  e1 = discard_nops (e1);
-  e2 = discard_nops (e2);
+  e1 = gfc_discard_nops (e1);
+  e2 = gfc_discard_nops (e2);
 
   if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
     {
@@ -515,8 +515,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result)
   if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER)
     return false;
 
-  e1 = discard_nops (e1);
-  e2 = discard_nops (e2);
+  e1 = gfc_discard_nops (e1);
+  e2 = gfc_discard_nops (e2);
 
   /* Inizialize tentatively, clear if we don't return anything.  */
   mpz_init (*result);
@@ -531,8 +531,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result)
 
   if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS)
     {
-      e1_op1 = discard_nops (e1->value.op.op1);
-      e1_op2 = discard_nops (e1->value.op.op2);
+      e1_op1 = gfc_discard_nops (e1->value.op.op1);
+      e1_op2 = gfc_discard_nops (e1->value.op.op2);
 
       /* Case 2: (X + c1) - X = c1.  */
       if (e1_op2->expr_type == EXPR_CONSTANT
@@ -552,8 +552,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result)
 
       if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
 	{
-	  e2_op1 = discard_nops (e2->value.op.op1);
-	  e2_op2 = discard_nops (e2->value.op.op2);
+	  e2_op1 = gfc_discard_nops (e2->value.op.op1);
+	  e2_op2 = gfc_discard_nops (e2->value.op.op2);
 
 	  if (e1_op2->expr_type == EXPR_CONSTANT)
 	    {
@@ -597,8 +597,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result)
 
       if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
 	{
-	  e2_op1 = discard_nops (e2->value.op.op1);
-	  e2_op2 = discard_nops (e2->value.op.op2);
+	  e2_op1 = gfc_discard_nops (e2->value.op.op1);
+	  e2_op2 = gfc_discard_nops (e2->value.op.op2);
 
 	  if (e1_op2->expr_type == EXPR_CONSTANT)
 	    {
@@ -627,8 +627,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result)
 
   if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS)
     {
-      e1_op1 = discard_nops (e1->value.op.op1);
-      e1_op2 = discard_nops (e1->value.op.op2);
+      e1_op1 = gfc_discard_nops (e1->value.op.op1);
+      e1_op2 = gfc_discard_nops (e1->value.op.op2);
 
       if (e1_op2->expr_type == EXPR_CONSTANT)
 	{
@@ -642,8 +642,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result)
 
 	  if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
 	    {
-	      e2_op1 = discard_nops (e2->value.op.op1);
-	      e2_op2 = discard_nops (e2->value.op.op2);
+	      e2_op1 = gfc_discard_nops (e2->value.op.op1);
+	      e2_op2 = gfc_discard_nops (e2->value.op.op2);
 
 	      /* Case 11: (X - c1) - (X + c2) = -( c1 + c2).  */
 	      if (e2_op2->expr_type == EXPR_CONSTANT
@@ -668,8 +668,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result)
 
 	  if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
 	    {
-	      e2_op1 = discard_nops (e2->value.op.op1);
-	      e2_op2 = discard_nops (e2->value.op.op2);
+	      e2_op1 = gfc_discard_nops (e2->value.op.op1);
+	      e2_op2 = gfc_discard_nops (e2->value.op.op2);
 
 	      /* Case 13: (X - c1) - (X - c2) = c2 - c1.  */
 	      if (e2_op2->expr_type == EXPR_CONSTANT
@@ -685,8 +685,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result)
 	{
 	  if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
 	    {
-	      e2_op1 = discard_nops (e2->value.op.op1);
-	      e2_op2 = discard_nops (e2->value.op.op2);
+	      e2_op1 = gfc_discard_nops (e2->value.op.op1);
+	      e2_op2 = gfc_discard_nops (e2->value.op.op2);
 
 	      /* Case 14: (c1 - X) - (c2 - X) == c1 - c2.  */
 	      if (gfc_dep_compare_expr (e1_op2, e2_op2) == 0)
@@ -702,8 +702,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result)
 
   if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS)
     {
-      e2_op1 = discard_nops (e2->value.op.op1);
-      e2_op2 = discard_nops (e2->value.op.op2);
+      e2_op1 = gfc_discard_nops (e2->value.op.op1);
+      e2_op2 = gfc_discard_nops (e2->value.op.op2);
 
       /* Case 15: X - (X + c2) = -c2.  */
       if (e2_op2->expr_type == EXPR_CONSTANT
@@ -723,8 +723,8 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result)
 
   if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS)
     {
-      e2_op1 = discard_nops (e2->value.op.op1);
-      e2_op2 = discard_nops (e2->value.op.op2);
+      e2_op1 = gfc_discard_nops (e2->value.op.op1);
+      e2_op2 = gfc_discard_nops (e2->value.op.op2);
 
       /* Case 17: X - (X - c2) = c2.  */
       if (e2_op2->expr_type == EXPR_CONSTANT

gcc/fortran/frontend-passes.c

@@ -42,6 +42,8 @@ static bool is_empty_string (gfc_expr *e);
 static void doloop_warn (gfc_namespace *);
 static void optimize_reduction (gfc_namespace *);
 static int callback_reduction (gfc_expr **, int *, void *);
+static void realloc_strings (gfc_namespace *);
+static gfc_expr *create_var (gfc_expr *);
 
 /* How deep we are inside an argument list.  */
 
@@ -113,6 +115,51 @@ gfc_run_passes (gfc_namespace *ns)
 
       expr_array.release ();
     }
+
+  if (flag_realloc_lhs)
+    realloc_strings (ns);
+}
+
+/* Callback for each gfc_code node invoked from check_realloc_strings.
+   For an allocatable LHS string which also appears as a variable on
+   the RHS, replace 
+
+   a = a(x:y)
+
+   with
+
+   tmp = a(x:y)
+   a = tmp
+ */
+
+static int
+realloc_string_callback (gfc_code **c, int *walk_subtrees,
+			 void *data ATTRIBUTE_UNUSED)
+{
+  gfc_expr *expr1, *expr2;
+  gfc_code *co = *c;
+  gfc_expr *n;
+
+  *walk_subtrees = 0;
+  if (co->op != EXEC_ASSIGN)
+    return 0;
+
+  expr1 = co->expr1;
+  if (expr1->ts.type != BT_CHARACTER || expr1->rank != 0
+      || !expr1->symtree->n.sym->attr.allocatable)
+    return 0;
+
+  expr2 = gfc_discard_nops (co->expr2);
+  if (expr2->expr_type != EXPR_VARIABLE)
+    return 0;
+
+  if (!gfc_check_dependency (expr1, expr2, true))
+    return 0;
+  
+  current_code = c;
+  n = create_var (expr2);
+  co->expr2 = n;
+  return 0;
 }
 
 /* Callback for each gfc_code node invoked through gfc_code_walker
@@ -430,6 +477,52 @@ is_fe_temp (gfc_expr *e)
   return e->symtree->n.sym->attr.fe_temp;
 }
 
+/* Determine the length of a string, if it can be evaluated as a constant
+   expression.  Return a newly allocated gfc_expr or NULL on failure.
+   If the user specified a substring which is potentially longer than
+   the string itself, the string will be padded with spaces, which
+   is harmless.  */
+
+static gfc_expr *
+constant_string_length (gfc_expr *e)
+{
+
+  gfc_expr *length;
+  gfc_ref *ref;
+  gfc_expr *res;
+  mpz_t value;
+
+  if (e->ts.u.cl)
+    {
+      length = e->ts.u.cl->length;
+      if (length && length->expr_type == EXPR_CONSTANT)
+	return gfc_copy_expr(length);
+    }
+
+  /* Return length of substring, if constant. */
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ref->type == REF_SUBSTRING
+	  && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &value))
+	{
+	  res = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind,
+				       &e->where);
+	  
+	  mpz_add_ui (res->value.integer, value, 1);
+	  mpz_clear (value);
+	  return res;
+	}
+    }
+
+  /* Return length of char symbol, if constant.  */
+
+  if (e->symtree->n.sym->ts.u.cl && e->symtree->n.sym->ts.u.cl->length
+      && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
+    return gfc_copy_expr (e->symtree->n.sym->ts.u.cl->length);
+
+  return NULL;
+
+}
 
 /* Returns a new expression (a variable) to be used in place of the old one,
    with an assignment statement before the current statement to set
@@ -525,6 +618,20 @@ create_var (gfc_expr * e)
 	}
     }
 
+  if (e->ts.type == BT_CHARACTER && e->rank == 0)
+    {
+      gfc_expr *length;
+
+      length = constant_string_length (e);
+      if (length)
+	{
+	  symbol->ts.u.cl = gfc_new_charlen (ns, NULL);
+	  symbol->ts.u.cl->length = length;
+	}
+      else
+	symbol->attr.allocatable = 1;
+    }
+
   symbol->attr.flavor = FL_VARIABLE;
   symbol->attr.referenced = 1;
   symbol->attr.dimension = e->rank > 0;
@@ -849,6 +956,26 @@ optimize_namespace (gfc_namespace *ns)
     }
 }
 
+/* Handle dependencies for allocatable strings which potentially redefine
+   themselves in an assignment.  */
+
+static void
+realloc_strings (gfc_namespace *ns)
+{
+  current_ns = ns;
+  gfc_code_walker (&ns->code, realloc_string_callback, dummy_expr_callback, NULL);
+
+  for (ns = ns->contained; ns; ns = ns->sibling)
+    {
+      if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
+	{
+	  // current_ns = ns;
+	  realloc_strings (ns);
+	}
+    }
+
+}
+
 static void
 optimize_reduction (gfc_namespace *ns)
 {
@@ -1567,6 +1694,11 @@ optimize_trim (gfc_expr *e)
   if (a->expr_type != EXPR_VARIABLE)
     return false;
 
+  /* This would pessimize the idiom a = trim(a) for reallocatable strings.  */
+
+  if (a->symtree->n.sym->attr.allocatable)
+    return false;
+
   /* Follow all references to find the correct place to put the newly
      created reference.  FIXME:  Also handle substring references and
      array references.  Array references cause strange regressions at

gcc/testsuite/ChangeLog

+2015-01-05  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/47674
+	* gfortran.dg/realloc_on_assign_25.f90:  New test.
+
 2015-01-05  Jakub Jelinek  <jakub@redhat.com>
 
 	Update copyright years.

gcc/testsuite/gfortran.dg/realloc_on_assign_25.f90

+! { dg-do run }
+! PR 47674 - this would segfault if MALLOC_PERTURB is set.
+! This checks a code path where it is not possible to determine
+! the length of the string at compile time.
+!
+program main
+  implicit none
+  character(:), allocatable :: a
+  integer :: m, n
+  a = 'a'
+  if (a .ne. 'a') call abort
+  a = a // 'x'
+  if (a .ne. 'ax') call abort
+  if (len (a) .ne. 2) call abort
+  n = 2
+  m = 2
+  a = a(m:n)
+  if (a .ne. 'x') call abort
+  if (len (a) .ne. 1) call abort
+end program main