diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 70ba4cce47320510ca42fd5aa56c5bb25db523a7..f3239d761022d4674741dd27f63277d231f4f7ab 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,12 @@
+2018-10-23 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/85603
+ * frontend-passes.c (get_len_call): New function to generate a
+ call to intrinsic LEN.
+ (create_var): Use this to make length expressions for variable
+ rhs string lengths.
+ Clean up some white space issues.
+
2018-10-21 Paul Thomas <pault@gcc.gnu.org>
PR fortran/71880
diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c
index 2a65b52fad72ce53e32ae1deb7367daab4025fb5..d380dcfb3cb429cea9d5d98f6b7944589113b4b6 100644
--- a/gcc/fortran/frontend-passes.c
+++ b/gcc/fortran/frontend-passes.c
@@ -280,7 +280,7 @@ realloc_string_callback (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
&& (expr2->expr_type != EXPR_OP
|| expr2->value.op.op != INTRINSIC_CONCAT))
return 0;
-
+
if (!gfc_check_dependency (expr1, expr2, true))
return 0;
@@ -704,6 +704,41 @@ insert_block ()
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
@@ -786,6 +821,10 @@ create_var (gfc_expr * e, const char *vname)
length = constant_string_length (e);
if (length)
symbol->ts.u.cl->length = length;
+ else if (e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->ts.type == BT_CHARACTER
+ && e->ts.u.cl->length)
+ symbol->ts.u.cl->length = get_len_call (gfc_copy_expr (e));
else
{
symbol->attr.allocatable = 1;
@@ -1226,7 +1265,7 @@ traverse_io_block (gfc_code *code, bool *has_reached, gfc_code *prev)
{
/* 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;
@@ -1286,7 +1325,7 @@ traverse_io_block (gfc_code *code, bool *has_reached, gfc_code *prev)
|| var_in_expr (var, iters[j]->end)
|| var_in_expr (var, iters[j]->step)))
return false;
- }
+ }
}
}
@@ -2019,6 +2058,7 @@ get_len_trim_call (gfc_expr *str, int kind)
return fcn;
}
+
/* Optimize expressions for equality. */
static bool
@@ -2626,7 +2666,7 @@ do_subscript (gfc_expr **e)
/* 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
@@ -2640,7 +2680,7 @@ do_subscript (gfc_expr **e)
else
have_do_start = false;
-
+
if (dl->ext.iterator->end->expr_type == EXPR_CONSTANT)
{
have_do_end = true;
@@ -2806,7 +2846,7 @@ matmul_to_var_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED,
{
gfc_expr *e, *n;
bool *found = (bool *) data;
-
+
e = *ep;
if (e->expr_type != EXPR_FUNCTION
@@ -2819,19 +2859,19 @@ matmul_to_var_expr (gfc_expr **ep, int *walk_subtrees ATTRIBUTE_UNUSED,
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;
@@ -2850,7 +2890,7 @@ matmul_to_var_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
inserted_block = NULL;
changed_statement = NULL;
}
-
+
return 0;
}
@@ -2870,7 +2910,7 @@ matmul_temp_args (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
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)
@@ -2920,7 +2960,7 @@ matmul_temp_args (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
if (!a_tmp && !b_tmp)
return 0;
-
+
current_code = c;
inserted_block = NULL;
changed_statement = NULL;
@@ -3648,7 +3688,7 @@ scalarized_expr (gfc_expr *e_in, gfc_expr **index, int count_index)
/* 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;
@@ -4604,7 +4644,7 @@ call_external_blas (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
default:
gcc_unreachable ();
}
- }
+ }
/* Handle the reallocation, if needed. */
@@ -4756,7 +4796,7 @@ typedef struct {
int n[GFC_MAX_DIMENSIONS];
} ind_type;
-/* Callback function to determine if an expression is the
+/* Callback function to determine if an expression is the
corresponding variable. */
static int
@@ -4842,7 +4882,7 @@ index_interchange (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
gfc_forall_iterator *fa;
ind_type *ind;
int i, j;
-
+
if (co->op != EXEC_FORALL && co->op != EXEC_DO_CONCURRENT)
return 0;
@@ -5358,7 +5398,7 @@ gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
if (co->op == EXEC_SELECT)
select_level --;
-
+
in_omp_workshare = saved_in_omp_workshare;
in_where = saved_in_where;
}
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 0a4700a3aae06df99af00909797e5835d5ce7b9c..9441c26e06dc817b4c405a2edf4bd037062cc558 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2018-10-23 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/85603
+ * gfortran.dg/deferred_character_23.f90 : Check reallocation is
+ occurring as it should and a regression caused by version 1 of
+ this patch.
+
2018-10-22 Yury Gribov <tetra2005@gmail.com>
PR tree-optimization/87633
diff --git a/gcc/testsuite/gfortran.dg/deferred_character_23.f90 b/gcc/testsuite/gfortran.dg/deferred_character_23.f90
index c018334688e2732c1db7ee71537c31ea6ca1ac76..5d8beca9dcd6c54234f6f1d280775291a6c42eb6 100644
--- a/gcc/testsuite/gfortran.dg/deferred_character_23.f90
+++ b/gcc/testsuite/gfortran.dg/deferred_character_23.f90
@@ -3,6 +3,29 @@
! Tests the fix for PR85603.
!
! Contributed by Walt Spector <w6ws@earthlink.net>
+!_____________________________________________
+! Module for a test against a regression that occurred with
+! the first patch for this PR.
+!
+MODULE TN4
+ IMPLICIT NONE
+ PRIVATE
+ INTEGER,PARAMETER::SH4=KIND('a')
+ TYPE,PUBLIC::TOP
+ CHARACTER(:,KIND=SH4),ALLOCATABLE::ROR
+ CHARACTER(:,KIND=SH4),ALLOCATABLE::VI8
+ CONTAINS
+ PROCEDURE,NON_OVERRIDABLE::SB=>TPX
+ END TYPE TOP
+CONTAINS
+ SUBROUTINE TPX(TP6,PP4)
+ CLASS(TOP),INTENT(INOUT)::TP6
+ INTEGER,INTENT(IN)::PP4
+ TP6%ROR=TP6%ROR(:PP4-1)
+ TP6%VI8=TP6%ROR(:PP4-1)
+ END SUBROUTINE TPX
+END MODULE TN4
+!_____________________________________________
!
program strlen_bug
implicit none
@@ -15,8 +38,31 @@ program strlen_bug
'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
+
+! 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
+
+! Test the regression, noted by Dominique d'Humieres is fixed.
+! Referenced in https://groups.google.com/forum/#!topic/comp.lang.fortran/nV3TlRlVKBc
+!
+ call foo
+contains
+ subroutine foo
+ USE TN4
+ TYPE(TOP) :: Z
+
+ Z%ROR = 'abcd'
+ call Z%SB (3)
+ if (Z%VI8 .ne. 'ab') stop 6
+end
+
end program