2017-10-16 Paul Thomas <pault@gcc.gnu.org>

	PR fortran/52832
	* match.c (gfc_match_associate): Before failing the association
	try again, allowing a proc pointer selector.

	PR fortran/80120
	PR fortran/81903
	PR fortran/82121
	* primary.c (gfc_match_varspec): Introduce 'tgt_expr', which
	points to the associate selector, if any. Go through selector
	references, after resolution for variables, to catch any full
	or section array references. If a class associate name does
	not have the same declared type as the selector, resolve the
	selector and copy the declared type to the associate name.
	Before throwing a no implicit type error, resolve all allowed
	selector expressions, and copy the resulting typespec.

	PR fortran/67543
	* resolve.c (resolve_assoc_var): Selector must cannot be the
	NULL expression and it must have a type.

	PR fortran/78152
	* resolve.c (resolve_symbol): Allow associate names to be
	coarrays.

2017-10-16  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/78512
	* gfortran.dg/associate_9.f03 : Remove XFAIL.
	* gfortran.dg/associate_26.f90 : New test.

	PR fortran/80120
	* gfortran.dg/associate_27.f90 : New test.

	PR fortran/81903
	* gfortran.dg/associate_28.f90 : New test.

	PR fortran/82121
	* gfortran.dg/associate_29.f90 : New test.

	PR fortran/67543
	* gfortran.dg/associate_30.f90 : New test.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/gcc-7-branch@253794 138bc75d-0d04-0410-961f-82ee72b054a4

11 files changed, 274 insertions, 24 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 43d4d22a3a9..3eefec546f2 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,5 +1,31 @@
 2017-10-16  Paul Thomas  <pault@gcc.gnu.org>
 
+	PR fortran/52832
+	* match.c (gfc_match_associate): Before failing the association
+	try again, allowing a proc pointer selector.
+
+	PR fortran/80120
+	PR fortran/81903
+	PR fortran/82121
+	* primary.c (gfc_match_varspec): Introduce 'tgt_expr', which
+	points to the associate selector, if any. Go through selector
+	references, after resolution for variables, to catch any full
+	or section array references. If a class associate name does
+	not have the same declared type as the selector, resolve the
+	selector and copy the declared type to the associate name.
+	Before throwing a no implicit type error, resolve all allowed
+	selector expressions, and copy the resulting typespec.
+
+	PR fortran/67543
+	* resolve.c (resolve_assoc_var): Selector must cannot be the
+	NULL expression and it must have a type.
+
+	PR fortran/78152
+	* resolve.c (resolve_symbol): Allow associate names to be
+	coarrays.
+
+2017-10-16  Paul Thomas  <pault@gcc.gnu.org>
+
 	Backport from trunk
 	PR fortran/81048
 	* resolve.c (resolve_symbol): Ensure that derived type array
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 006ac0312ac..1c23cc3b22a 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1882,8 +1882,15 @@ gfc_match_associate (void)
       if (gfc_match (" %n => %e", newAssoc->name, &newAssoc->target)
 	    != MATCH_YES)
 	{
-	  gfc_error ("Expected association at %C");
-	  goto assocListError;
+	  /* Have another go, allowing for procedure pointer selectors.  */
+	  gfc_matching_procptr_assignment = 1;
+	  if (gfc_match (" %n => %e", newAssoc->name, &newAssoc->target)
+ 	      != MATCH_YES)
+ 	    {
+ 	      gfc_error ("Expected association at %C");
+ 	      goto assocListError;
+ 	    }
+	  gfc_matching_procptr_assignment = 0;
 	}
       newAssoc->where = gfc_current_locus;
 
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index c12dc3562d3..b97b4a1ca59 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -1890,6 +1890,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
   gfc_ref *substring, *tail, *tmp;
   gfc_component *component;
   gfc_symbol *sym = primary->symtree->n.sym;
+  gfc_expr *tgt_expr = NULL;
   match m;
   bool unknown;
   char sep;
@@ -1918,6 +1919,9 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
 	}
     }
 
+  if (sym->assoc && sym->assoc->target)
+    tgt_expr = sym->assoc->target;
+
   /* 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
@@ -1929,26 +1933,43 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
       && 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
+      gfc_ref *ref = NULL;
+
+      if (!sym->assoc->dangling && tgt_expr)
+	{
+	   if (tgt_expr->expr_type == EXPR_VARIABLE)
+	     gfc_resolve_expr (tgt_expr);
+
+	   ref = tgt_expr->ref;
+	   for (; ref; ref = ref->next)
+	      if (ref->type == REF_ARRAY
+		  && (ref->u.ar.type == AR_FULL
+		      || ref->u.ar.type == AR_SECTION))
+		break;
+	}
+
+      if (ref || (!(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->st
 	      && sym->assoc->st->n.sym
 	      && sym->assoc->st->n.sym->as)
 	    sym->as = gfc_copy_array_spec (sym->assoc->st->n.sym->as);
 	}
     }
+  else if (sym->ts.type == BT_CLASS
+	   && tgt_expr
+	   && tgt_expr->expr_type == EXPR_VARIABLE
+	   && sym->ts.u.derived != tgt_expr->ts.u.derived)
+    {
+      gfc_resolve_expr (tgt_expr);
+      if (tgt_expr->rank)
+	sym->ts.u.derived = tgt_expr->ts.u.derived;
+    }
 
   if ((equiv_flag && gfc_peek_ascii_char () == '(')
       || gfc_peek_ascii_char () == '[' || sym->attr.codimension
@@ -2008,10 +2029,31 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
       && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
     gfc_set_default_type (sym, 0, sym->ns);
 
+  /* See if there is a usable typespec in the "no IMPLICIT type" error.  */
   if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES)
     {
-      gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym->name);
-      return MATCH_ERROR;
+      bool permissible;
+
+      /* These target expressions can ge 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
+			|| tgt_expr->symtree->n.sym->attr.if_source
+								== IFSRC_DECL);
+      permissible = permissible
+		    || (tgt_expr && tgt_expr->expr_type == EXPR_OP);
+
+      if (permissible)
+	{
+	  gfc_resolve_expr (tgt_expr);
+	  sym->ts = tgt_expr->ts;
+	}
+
+      if (sym->ts.type == BT_UNKNOWN)
+	{
+	  gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym->name);
+	  return MATCH_ERROR;
+	}
     }
   else if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
            && m == MATCH_YES)
@@ -2948,7 +2990,7 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
      expression here.  */
   if (gfc_in_match_data ())
     gfc_reduce_init_expr (e);
- 
+
   *result = e;
   return MATCH_YES;
 }
@@ -3662,7 +3704,7 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
 	implicit_ns = gfc_current_ns;
       else
 	implicit_ns = sym->ns;
-	
+
       old_loc = gfc_current_locus;
       if (gfc_match_member_sep (sym) == MATCH_YES
 	  && sym->ts.type == BT_UNKNOWN
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 065d17be05a..494196257ed 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -8294,11 +8294,23 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target)
 	sym->attr.subref_array_pointer = 1;
     }
 
+  if (target->expr_type == EXPR_NULL)
+    {
+      gfc_error ("Selector at %L cannot be NULL()", &target->where);
+      return;
+    }
+  else if (target->ts.type == BT_UNKNOWN)
+    {
+      gfc_error ("Selector at %L has no type", &target->where);
+      return;
+    }
+
   /* Get type if this was not already set.  Note that it can be
      some other type than the target in case this is a SELECT TYPE
      selector!  So we must not update when the type is already there.  */
   if (sym->ts.type == BT_UNKNOWN)
     sym->ts = target->ts;
+
   gcc_assert (sym->ts.type != BT_UNKNOWN);
 
   /* See if this is a valid association-to-variable.  */
@@ -11824,6 +11836,7 @@ deferred_requirements (gfc_symbol *sym)
   if (sym->ts.deferred
       && !(sym->attr.pointer
 	   || sym->attr.allocatable
+	   || sym->attr.associate_var
 	   || sym->attr.omp_udr_artificial_var))
     {
       gfc_error ("Entity %qs at %L has a deferred type parameter and "
@@ -14609,6 +14622,7 @@ resolve_symbol (gfc_symbol *sym)
   if (class_attr.codimension
       && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save
 	   || sym->attr.select_type_temporary
+	   || sym->attr.associate_var
 	   || (sym->ns->save_all && !sym->attr.automatic)
 	   || sym->ns->proc_name->attr.flavor == FL_MODULE
 	   || sym->ns->proc_name->attr.is_main_program
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 06c15b41bf5..e0b75bfd1e9 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,5 +1,23 @@
 2017-10-16  Paul Thomas  <pault@gcc.gnu.org>
 
+	PR fortran/78512
+	* gfortran.dg/associate_9.f03 : Remove XFAIL.
+	* gfortran.dg/associate_26.f90 : New test.
+
+	PR fortran/80120
+	* gfortran.dg/associate_27.f90 : New test.
+
+	PR fortran/81903
+	* gfortran.dg/associate_28.f90 : New test.
+
+	PR fortran/82121
+	* gfortran.dg/associate_29.f90 : New test.
+
+	PR fortran/67543
+	* gfortran.dg/associate_30.f90 : New test.
+
+2017-10-16  Paul Thomas  <pault@gcc.gnu.org>
+
 	Backport from trunk
 	PR fortran/81048
 	* gfortran.dg/derived_init_4.f90 : New test.
diff --git a/gcc/testsuite/gfortran.dg/associate_26.f90 b/gcc/testsuite/gfortran.dg/associate_26.f90
new file mode 100644
index 00000000000..ae19acaf777
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_26.f90
@@ -0,0 +1,15 @@
+! { dg-do compile }
+! { dg-options "-fcoarray=single" }
+!
+! Test the fix for PR78152
+!
+! Contributed by <physiker@toast2.net>
+!
+program co_assoc
+  implicit none
+  integer, parameter :: p = 5
+  real, allocatable :: a(:,:)[:,:]
+  allocate (a(p,p)[2,*])
+    associate (i => a(1:p, 1:p))
+  end associate
+end program co_assoc
diff --git a/gcc/testsuite/gfortran.dg/associate_27.f90 b/gcc/testsuite/gfortran.dg/associate_27.f90
new file mode 100644
index 00000000000..6fcb8a990fd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_27.f90
@@ -0,0 +1,23 @@
+! { dg-do run }
+!
+! Test the fix for PR80120
+!
+! Contributed by Marco Restelli  <mrestelli@gmail.com>
+!
+program p
+ implicit none
+
+ type :: t
+  character(len=25) :: text(2)
+ end type t
+ type(t) :: x
+
+ x%text(1) = "ABC"
+ x%text(2) = "defgh"
+
+ associate( c => x%text )
+   if (c(1)(:maxval(len_trim(c))) .ne. trim (x%text(1))) call abort
+   if (c(2)(:maxval(len_trim(c))) .ne. trim (x%text(2))) call abort
+ end associate
+
+end program p
diff --git a/gcc/testsuite/gfortran.dg/associate_28.f90 b/gcc/testsuite/gfortran.dg/associate_28.f90
new file mode 100644
index 00000000000..8715472799e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_28.f90
@@ -0,0 +1,64 @@
+! { dg-do run }
+!
+! Test the fix for PR81903
+!
+! Contributed by Karl May  <karl.may0@freenet.de>
+!
+Module TestMod_A
+  Type :: TestType_A
+    Real, Allocatable :: a(:,:)
+  End type TestType_A
+End Module TestMod_A
+Module TestMod_B
+  Type :: TestType_B
+   Real, Pointer, contiguous :: a(:,:)
+  End type TestType_B
+End Module TestMod_B
+Module TestMod_C
+  use TestMod_A
+  use TestMod_B
+  Implicit None
+  Type :: TestType_C
+    Class(TestType_A), Pointer :: TT_A(:)
+    Type(TestType_B), Allocatable :: TT_B(:)
+  contains
+    Procedure, Pass :: SetPt => SubSetPt
+  End type TestType_C
+  Interface
+    Module Subroutine SubSetPt(this)
+      class(TestType_C), Intent(InOut), Target :: this
+    End Subroutine
+  End Interface
+End Module TestMod_C
+Submodule(TestMod_C) SetPt
+contains
+  Module Procedure SubSetPt
+    Implicit None
+    integer :: i
+    integer :: sum_a = 0
+    outer:block
+      associate(x=>this%TT_B,y=>this%TT_A)
+        Do i=1,size(x)
+          x(i)%a=>y(i)%a
+          sum_a = sum_a + sum (int (x(i)%a))
+        End Do
+      end associate
+    End block outer
+    if (sum_a .ne. 30) call abort
+  End Procedure
+End Submodule SetPt
+Program Test
+  use TestMod_C
+  use TestMod_A
+  Implicit None
+  Type(TestType_C) :: tb
+  Type(TestType_A), allocatable, Target :: ta(:)
+  integer :: i
+  real :: src(2,2) = reshape ([(real(i), i = 1,4)],[2,2])
+  allocate(ta(2),tb%tt_b(2))
+  do i=1,size(ta)
+    allocate(ta(i)%a(2,2), source = src*real(i))
+  End do
+  tb%TT_A=>ta
+  call tb%setpt()
+End Program Test
diff --git a/gcc/testsuite/gfortran.dg/associate_29.f90 b/gcc/testsuite/gfortran.dg/associate_29.f90
new file mode 100644
index 00000000000..786e3c52e8b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_29.f90
@@ -0,0 +1,30 @@
+! { dg-do compile }
+!
+! Test the fix for PR82121
+!
+! Contributed by Iain Miller  <iain.miller@ecmwf.int>
+!
+MODULE YOMCDDH
+  IMPLICIT NONE
+  SAVE
+  TYPE :: TCDDH
+    CHARACTER(len=12),ALLOCATABLE :: CADHTLS(:)
+  END TYPE TCDDH
+  CHARACTER(len=12),ALLOCATABLE :: CADHTTS(:)
+  TYPE(TCDDH), POINTER :: YRCDDH => NULL()
+END MODULE YOMCDDH
+
+
+SUBROUTINE SUCDDH()
+  USE YOMCDDH  , ONLY : YRCDDH,CADHTTS
+  IMPLICIT NONE
+  ALLOCATE (YRCDDH%CADHTLS(20))
+  ALLOCATE (CADHTTS(20))
+  ASSOCIATE(CADHTLS=>YRCDDH%CADHTLS, NORMCHAR=>CADHTTS)
+! Direct reference to character array compiled correctly
+!    YRCDDH%CADHTLS(1)='SVGTLF'
+! Reference to associated variable name failed to compile
+    CADHTLS(2)='SVGTLT'
+    NORMCHAR(1)='SVLTTC'
+  END ASSOCIATE
+END SUBROUTINE SUCDDH
diff --git a/gcc/testsuite/gfortran.dg/associate_30.f90 b/gcc/testsuite/gfortran.dg/associate_30.f90
new file mode 100644
index 00000000000..ad15d8bf576
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_30.f90
@@ -0,0 +1,15 @@
+! { dg-do compile }
+!
+! Test the fix for PR67543
+!
+! Contributed by Gerhard Steinmetz  <gerhard.steinmetz.fortran@t-online.de>
+!
+   subroutine s1
+      associate (x => null())   ! { dg-error "cannot be NULL()" }
+      end associate
+   end subroutine
+
+   subroutine s2
+      associate (x => [null()]) ! { dg-error "has no type" }
+      end associate
+   end subroutine
diff --git a/gcc/testsuite/gfortran.dg/associate_9.f03 b/gcc/testsuite/gfortran.dg/associate_9.f03
index 3a262b6da09..bf44f47d2d0 100644
--- a/gcc/testsuite/gfortran.dg/associate_9.f03
+++ b/gcc/testsuite/gfortran.dg/associate_9.f03
@@ -1,8 +1,6 @@
 ! { dg-do compile }
 ! { dg-options "-std=f2003 -fall-intrinsics" }
 
-! FIXME: Change into run test and remove excess error expectation.
-
 ! PR fortran/38936
 ! Association to derived-type, where the target type is not know
 ! during parsing (only resolution).
@@ -46,5 +44,3 @@ PROGRAM main
     IF (x%comp /= 10) CALL abort ()
   END ASSOCIATE
 END PROGRAM main
-
-! { dg-excess-errors "Syntex error in IF" }