[Patch, fortran] PR64933 - ASSOCIATE on a character variable does not allow substring expressions

[Paul Richard Thomas]

Dear All,

The associate construct does not readily permit the identification of
the associate name as an array during parsing. However, this can be
done whilst matching rvalues within the associate block. This patch
extends this identification in gfc_match_varspec, whilst excluding
character types from the present test. This latter change prevents
scalar substrings from being pegged as array references, which was the
origin of this bug.

Bootstraps and regtests on FC21/x86_64.

OK for trunk?

Paul

2016-04-19  Paul Thomas  <pa...@gcc.gnu.org>

    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  <pa...@gcc.gnu.org>

    PR fortran/64933
    * gfortran.dg/associate_23.f90: New test.


-- 
The difference between genius and stupidity is; genius has its limits.

Albert Einstein

Index: gcc/fortran/primary.c
===================================================================
*** gcc/fortran/primary.c       (revision 241831)
--- gcc/fortran/primary.c       (working copy)
*************** gfc_match_varspec (gfc_expr *primary, in
*** 1931,1945 ****
      }
  
    /* 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
           && sym->assoc->st->n.sym
!          && sym->assoc->st->n.sym->attr.dimension == 0)
!       && sym->ts.type != BT_CLASS)
      sym->attr.dimension = 1;
  
    if ((equiv_flag && gfc_peek_ascii_char () == '(')
        || gfc_peek_ascii_char () == '[' || sym->attr.codimension
--- 1931,1966 ----
      }
  
    /* For associate names, we may not yet know whether they are arrays or not.
!      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->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
Index: gcc/testsuite/gfortran.dg/associate_23.f90
===================================================================
*** gcc/testsuite/gfortran.dg/associate_23.f90  (revision 0)
--- gcc/testsuite/gfortran.dg/associate_23.f90  (working copy)
***************
*** 0 ****
--- 1,36 ----
+ ! { dg-do run }
+ !
+ ! Tests the fix for PR64933
+ !
+ ! Contributed by Olivier Marsden  <olivier.mars...@ecmwf.int>
+ !
+ 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