FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

re PR fortran/85603 (ICE with character array substring assignment)

Browse source 
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 2018-10-23 08:27:14 +00:00
parent a847d2b7b1
commit 2efade53fe
4 changed files with 121 additions and 19 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
gcc/fortran/ChangeLog
View file

@ -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

40
gcc/fortran/frontend-passes.c
View file

@ -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;
@ -2019,6 +2058,7 @@ get_len_trim_call (gfc_expr *str, int kind)
return fcn;
}
/* Optimize expressions for equality. */
static bool

7
gcc/testsuite/ChangeLog
View file

@ -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

50
gcc/testsuite/gfortran.dg/deferred_character_23.f90
View file

@ -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