re PR fortran/85603 (ICE with character array substring assignment)
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-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. From-SVN: r265412
This commit is contained in:
Paul Thomas
parent
a847d2b7b1
commit
2efade53fe
4 changed files with 121 additions and 19 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue