OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/84115 (Failure in associate construct with concatenated character target)

Browse Source 
2018-02-17  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/84115
	* resolve.c (resolve_assoc_var): If a non-constant target expr.
	has no string length expression, make the associate variable
	into a deferred length, allocatable symbol.
	* trans-decl.c (gfc_is_reallocatable_lhs): Add and use a ptr to
	the symbol.
	* trans-stmt.c (trans_associate_var): Null and free scalar
	associate names that are allocatable. After assignment, remove
	the allocatable attribute to prevent reallocation.

2018-02-17  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/84115
	* gfortran.dg/associate_35.f90: Remove error, add stop n's and
	change to run.

From-SVN: r257781
This commit is contained in:
Paul Thomas 2018-02-17 11:07:32 +00:00
parent 9f533a82db
commit a8399af846
8 changed files with 84 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
gcc/fortran/ChangeLog
View File

@ -1,3 +1,15 @@
2018-02-17 Paul Thomas <pault@gcc.gnu.org>
PR fortran/84115
* resolve.c (resolve_assoc_var): If a non-constant target expr.
has no string length expression, make the associate variable
into a deferred length, allocatable symbol.
* trans-decl.c (gfc_is_reallocatable_lhs): Add and use a ptr to
the symbol.
* trans-stmt.c (trans_associate_var): Null and free scalar
associate names that are allocatable. After assignment, remove
the allocatable attribute to prevent reallocation.
2018-02-16 Jakub Jelinek <jakub@redhat.com>
PR fortran/84418

2
gcc/fortran/primary.c
View File

@ -2082,7 +2082,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
{
bool permissible;
/* These target expressions can ge resolved at any time. */
/* These target expressions can be resolved at any time. */
permissible = tgt_expr && tgt_expr->symtree && tgt_expr->symtree->n.sym
&& (tgt_expr->symtree->n.sym->attr.use_assoc
|| tgt_expr->symtree->n.sym->attr.host_assoc

15
gcc/fortran/resolve.c
View File

@ -8635,7 +8635,20 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
if (sym->ts.type == BT_CHARACTER && !sym->attr.select_type_temporary)
{
if (!sym->ts.u.cl)
sym->ts.u.cl = target->ts.u.cl;
{
if (target->expr_type != EXPR_CONSTANT
&& !target->ts.u.cl->length)
{
sym->ts.u.cl = gfc_get_charlen();
sym->ts.deferred = 1;
/* This is reset in trans-stmt.c after the assignment
of the target expression to the associate name. */
sym->attr.allocatable = 1;
}
else
sym->ts.u.cl = target->ts.u.cl;
}
if (!sym->ts.u.cl->length && !sym->ts.deferred)
{

15
gcc/fortran/trans-array.c
View File

@ -9470,29 +9470,32 @@ bool
gfc_is_reallocatable_lhs (gfc_expr *expr)
{
gfc_ref * ref;
gfc_symbol *sym;
if (!expr->ref)
return false;
sym = expr->symtree->n.sym;
/* An allocatable class variable with no reference. */
if (expr->symtree->n.sym->ts.type == BT_CLASS
&& CLASS_DATA (expr->symtree->n.sym)->attr.allocatable
if (sym->ts.type == BT_CLASS
&& CLASS_DATA (sym)->attr.allocatable
&& expr->ref && expr->ref->type == REF_COMPONENT
&& strcmp (expr->ref->u.c.component->name, "_data") == 0
&& expr->ref->next == NULL)
return true;
/* An allocatable variable. */
if (expr->symtree->n.sym->attr.allocatable
if (sym->attr.allocatable
&& expr->ref
&& expr->ref->type == REF_ARRAY
&& expr->ref->u.ar.type == AR_FULL)
return true;
/* All that can be left are allocatable components. */
if ((expr->symtree->n.sym->ts.type != BT_DERIVED
&& expr->symtree->n.sym->ts.type != BT_CLASS)
|| !expr->symtree->n.sym->ts.u.derived->attr.alloc_comp)
if ((sym->ts.type != BT_DERIVED
&& sym->ts.type != BT_CLASS)
|| !sym->ts.u.derived->attr.alloc_comp)
return false;
/* Find a component ref followed by an array reference. */

2
gcc/fortran/trans-expr.c
View File

@ -657,7 +657,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
}
/* Array references with vector subscripts and non-variable expressions
need be coverted to a one-based descriptor. */
need be converted to a one-based descriptor. */
if (ref || e->expr_type != EXPR_VARIABLE)
{
for (dim = 0; dim < e->rank; ++dim)

34
gcc/fortran/trans-stmt.c
View File

@ -1926,9 +1926,26 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
{
gfc_expr *lhs;
tree res;
gfc_se se;
gfc_init_se (&se, NULL);
/* resolve.c converts some associate names to allocatable so that
allocation can take place automatically in gfc_trans_assignment.
The frontend prevents them from being either allocated,
deallocated or reallocated. */
if (sym->attr.allocatable)
{
tmp = sym->backend_decl;
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
tmp = gfc_conv_descriptor_data_get (tmp);
gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp),
null_pointer_node));
}
lhs = gfc_lval_expr_from_sym (sym);
res = gfc_trans_assignment (lhs, e, false, true);
gfc_add_expr_to_block (&se.pre, res);
tmp = sym->backend_decl;
if (e->expr_type == EXPR_FUNCTION
@ -1948,8 +1965,25 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
tmp = gfc_deallocate_pdt_comp (CLASS_DATA (sym)->ts.u.derived,
tmp, 0);
}
else if (sym->attr.allocatable)
{
tmp = sym->backend_decl;
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
tmp = gfc_conv_descriptor_data_get (tmp);
/* A simple call to free suffices here. */
tmp = gfc_call_free (tmp);
/* Make sure that reallocation on assignment cannot occur. */
sym->attr.allocatable = 0;
}
else
tmp = NULL_TREE;
res = gfc_finish_block (&se.pre);
gfc_add_init_cleanup (block, res, tmp);
gfc_free_expr (lhs);
}
/* Set the stringlength, when needed. */

8
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,9 @@
2018-02-17 Paul Thomas <pault@gcc.gnu.org>
PR fortran/84115
* gfortran.dg/associate_35.f90: Remove error, add STOP n and
change to dg-run.
2018-02-16 Eric Botcazou <ebotcazou@adacore.com>
PR ada/84277
@ -492,7 +498,7 @@
PR sanitizer/83987
* g++.dg/ubsan/pr83987-2.C: New test.
2018-02-09 Sebastian Perta <sebastian.perta@renesas.com>
* gcc.target/rx/movsicc.c: New test.

12
gcc/testsuite/gfortran.dg/associate_35.f90
View File

@ -1,6 +1,6 @@
! { dg-do compile }
! { dg-do run }
!
! Test the fix for PR84115 comment #1 (except for s1(x)!).
! Test the fix for PR84115 comment #1.
!
! Contributed by G Steinmetz <gscfq@t-online.de>
!
@ -14,22 +14,22 @@
contains
subroutine s1(x)
character(:), allocatable :: x
associate (y => x//x) ! { dg-error "type character and non-constant length" }
print *, y
associate (y => x//x)
if (y .ne. x//x) stop 1
end associate
end
subroutine s2(x)
character(:), allocatable :: x
associate (y => [x])
print *, y
if (any(y .ne. [x])) stop 2
end associate
end
subroutine s3(x)
character(:), allocatable :: x
associate (y => [x,x])
print *, y
if (any(y .ne. [x,x])) stop 3
end associate
end
end