From 2efade53fe39a9bd526997fb7cfe1d1d171a715d Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Tue, 23 Oct 2018 08:27:14 +0000 Subject: [PATCH] re PR fortran/85603 (ICE with character array substring assignment) 2018-10-23 Paul Thomas 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-23 Paul Thomas 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. From-SVN: r265412 --- gcc/fortran/ChangeLog | 9 +++ gcc/fortran/frontend-passes.c | 74 ++++++++++++++----- gcc/testsuite/ChangeLog | 7 ++ .../gfortran.dg/deferred_character_23.f90 | 50 ++++++++++++- 4 files changed, 121 insertions(+), 19 deletions(-) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 70ba4cce473..f3239d76102 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,12 @@ +2018-10-23 Paul Thomas + + 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 PR fortran/71880 diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c index 2a65b52fad7..d380dcfb3cb 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; jvar->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 0a4700a3aae..9441c26e06d 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2018-10-23 Paul Thomas + + 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 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 c018334688e..5d8beca9dcd 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 +!_____________________________________________ +! 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 -- 2.30.2