re PR fortran/64933 (ASSOCIATE on a character variable does not allow substring expressions)

2016-04-19  Paul Thomas  <pault@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  <pault@gcc.gnu.org>

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

From-SVN: r241860

4 files changed, 77 insertions, 7 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index b3cc871..f6b739c 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2016-04-19  Paul Thomas  <pault@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-11-03  Fritz Reese <fritzoreese@gmail.com>
 
 	* gfortran.texi: Document.
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index f26740d..50d7072 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 4ca326b..3babf14 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2016-04-19  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/64933
+	* gfortran.dg/associate_23.f90: New test.
+
 2016-11-04  Jakub Jelinek  <jakub@redhat.com>
 
 	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 0000000..b4d58ff
--- /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  <olivier.marsden@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