From b125dc1e1bb5932a2de833e07bbdc2395097a868 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Fri, 4 Nov 2016 19:23:44 +0000 Subject: [PATCH] re PR fortran/64933 (ASSOCIATE on a character variable does not allow substring expressions) 2016-04-19 Paul Thomas PR fortran/64933 * primary.c (gfc_match_varspec): If selector expression is unambiguously an array, make sure that the associate name is an array and has an array spec. Modify the original condition for doing this to exclude character types. 2016-04-19 Paul Thomas PR fortran/64933 * gfortran.dg/associate_23.f90: New test. From-SVN: r241860 --- gcc/fortran/ChangeLog | 8 +++++ gcc/fortran/primary.c | 35 ++++++++++++++++----- gcc/testsuite/ChangeLog | 5 +++ gcc/testsuite/gfortran.dg/associate_23.f90 | 36 ++++++++++++++++++++++ 4 files changed, 77 insertions(+), 7 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/associate_23.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index b3cc871688c..f6b739c84eb 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2016-04-19 Paul Thomas + + PR fortran/64933 + * primary.c (gfc_match_varspec): If selector expression is + unambiguously an array, make sure that the associate name + is an array and has an array spec. Modify the original + condition for doing this to exclude character types. + 2016-11-03 Fritz Reese * gfortran.texi: Document. diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index f26740d42ef..50d7072b670 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -1931,15 +1931,36 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, } /* For associate names, we may not yet know whether they are arrays or not. - Thus if we have one and parentheses follow, we have to assume that it - actually is one for now. The final decision will be made at - resolution time, of course. */ - if (sym->assoc && gfc_peek_ascii_char () == '(' - && !(sym->assoc->dangling && sym->assoc->st + If the selector expression is unambiguously an array; eg. a full array + or an array section, then the associate name must be an array and we can + fix it now. Otherwise, if parentheses follow and it is not a character + type, we have to assume that it actually is one for now. The final + decision will be made at resolution, of course. */ + if (sym->assoc + && gfc_peek_ascii_char () == '(' + && sym->ts.type != BT_CLASS + && !sym->attr.dimension) + { + if ((!sym->assoc->dangling + && sym->assoc->target + && sym->assoc->target->ref + && sym->assoc->target->ref->type == REF_ARRAY + && (sym->assoc->target->ref->u.ar.type == AR_FULL + || sym->assoc->target->ref->u.ar.type == AR_SECTION)) + || + (!(sym->assoc->dangling || sym->ts.type == BT_CHARACTER) + && sym->assoc->st && sym->assoc->st->n.sym - && sym->assoc->st->n.sym->attr.dimension == 0) - && sym->ts.type != BT_CLASS) + && sym->assoc->st->n.sym->attr.dimension == 0)) + { sym->attr.dimension = 1; + if (sym->as == NULL && sym->assoc + && sym->assoc->st + && sym->assoc->st->n.sym + && sym->assoc->st->n.sym->as) + sym->as = gfc_copy_array_spec (sym->assoc->st->n.sym->as); + } + } if ((equiv_flag && gfc_peek_ascii_char () == '(') || gfc_peek_ascii_char () == '[' || sym->attr.codimension diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 4ca326b5759..3babf14777b 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2016-04-19 Paul Thomas + + PR fortran/64933 + * gfortran.dg/associate_23.f90: New test. + 2016-11-04 Jakub Jelinek PR target/77834 diff --git a/gcc/testsuite/gfortran.dg/associate_23.f90 b/gcc/testsuite/gfortran.dg/associate_23.f90 new file mode 100644 index 00000000000..b4d58ffd2b7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/associate_23.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! +! Tests the fix for PR64933 +! +! Contributed by Olivier Marsden +! +program test_this + implicit none + character(len = 15) :: char_var, char_var_dim (3) + character(len = 80) :: buffer + +! Original failing case reported in PR + ASSOCIATE(should_work=>char_var) + should_work = "test succesful" + write (buffer, *) should_work(5:14) + END ASSOCIATE + + if (trim (buffer) .ne. " succesful") call abort + +! Found to be failing during debugging + ASSOCIATE(should_work=>char_var_dim) + should_work = ["test SUCCESFUL", "test_SUCCESFUL", "test.SUCCESFUL"] + write (buffer, *) should_work(:)(5:14) + END ASSOCIATE + + if (trim (buffer) .ne. " SUCCESFUL_SUCCESFUL.SUCCESFUL") call abort + +! Found to be failing during debugging + ASSOCIATE(should_work=>char_var_dim(1:2)) + should_work = ["test SUCCESFUL", "test_SUCCESFUL", "test.SUCCESFUL"] + write (buffer, *) should_work(:)(5:14) + END ASSOCIATE + + if (trim (buffer) .ne. " SUCCESFUL_SUCCESFUL") call abort + +end program -- 2.30.2