From a8399af846a1f9c71f1275f3de74ff3f8a86532a Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Sat, 17 Feb 2018 11:07:32 +0000 Subject: [PATCH] re PR fortran/84115 (Failure in associate construct with concatenated character target) 2018-02-17 Paul Thomas 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 PR fortran/84115 * gfortran.dg/associate_35.f90: Remove error, add stop n's and change to run. From-SVN: r257781 --- gcc/fortran/ChangeLog | 12 ++++++++ gcc/fortran/primary.c | 2 +- gcc/fortran/resolve.c | 15 +++++++++- gcc/fortran/trans-array.c | 15 ++++++---- gcc/fortran/trans-expr.c | 2 +- gcc/fortran/trans-stmt.c | 34 ++++++++++++++++++++++ gcc/testsuite/ChangeLog | 8 ++++- gcc/testsuite/gfortran.dg/associate_35.f90 | 12 ++++---- 8 files changed, 84 insertions(+), 16 deletions(-) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 445b9cce222..af345eafd5c 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,15 @@ +2018-02-17 Paul Thomas + + 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 PR fortran/84418 diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 3d076736fdc..9e6a8fe0d80 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -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 diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 01e2c38952c..e1d2aa27ad1 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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) { diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 4ffda26ca7d..79d4d171bdd 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -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. */ diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index a4185820531..04e06efbe38 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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) diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 573fd4818d4..71e22d80e98 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -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. */ diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index f3b1f9bccbf..4bc2d3e7f76 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2018-02-17 Paul Thomas + + PR fortran/84115 + * gfortran.dg/associate_35.f90: Remove error, add STOP n and + change to dg-run. + 2018-02-16 Eric Botcazou PR ada/84277 @@ -492,7 +498,7 @@ PR sanitizer/83987 * g++.dg/ubsan/pr83987-2.C: New test. - + 2018-02-09 Sebastian Perta * gcc.target/rx/movsicc.c: New test. diff --git a/gcc/testsuite/gfortran.dg/associate_35.f90 b/gcc/testsuite/gfortran.dg/associate_35.f90 index 417ec7c426b..67329785bc4 100644 --- a/gcc/testsuite/gfortran.dg/associate_35.f90 +++ b/gcc/testsuite/gfortran.dg/associate_35.f90 @@ -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 ! @@ -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 -- 2.30.2