re PR fortran/52832 ([F03] ASSOCIATE construct with proc-pointer selector is rejected)

2017-09-21  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-09-21  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/78512
	* 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.

	PR fortran/52832
	* gfortran.dg/associate_31.f90 : New test.

From-SVN: r253077

gcc/fortran/ChangeLog

+2017-09-21  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-09-21  Cesar Philippidis  <cesar@codesourcery.com>
 
 	* openmp.c (gfc_match_oacc_wait): Don't restrict wait directive

gcc/fortran/match.c

@@ -1885,8 +1885,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;
 

gcc/fortran/primary.c

@@ -1937,6 +1937,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;
@@ -1965,6 +1966,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
@@ -1976,26 +1980,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
@@ -2055,14 +2076,24 @@ 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);
 
-  /* Before throwing an error try resolving the target expression of
-     associate names. This should resolve function calls, for example.  */
+  /* See if there is a usable typespec in the "no IMPLICIT type" error.  */
   if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES)
     {
-      if (sym->assoc && sym->assoc->target)
+      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 (sym->assoc->target);
-	  sym->ts = sym->assoc->target->ts;
+	  gfc_resolve_expr (tgt_expr);
+	  sym->ts = tgt_expr->ts;
 	}
 
       if (sym->ts.type == BT_UNKNOWN)

gcc/fortran/resolve.c

@@ -8396,11 +8396,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.  */
@@ -11926,6 +11938,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 "
@@ -14763,6 +14776,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

gcc/testsuite/ChangeLog

+2017-09-21  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/78512
+	* 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.
+
+	PR fortran/52832
+	* gfortran.dg/associate_31.f90 : New test.
+
 2017-09-21  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* gnat.dg/discr48.adb: New test.
@@ -42,7 +62,7 @@
 	    Jeff Law  <law@redhat.com>
 
 	* gcc.dg/stack-check-5.c:  Add argument for s390.
-	* lib/target-supports.exp: 
+	* lib/target-supports.exp:
 	(check_effective_target_supports_stack_clash_protection): Enable for
 	s390/s390x targets.
 

gcc/testsuite/gfortran.dg/associate_26.f90

+! { 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

gcc/testsuite/gfortran.dg/associate_27.f90

+! { 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

gcc/testsuite/gfortran.dg/associate_28.f90

+! { 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

gcc/testsuite/gfortran.dg/associate_29.f90

+! { 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

gcc/testsuite/gfortran.dg/associate_30.f90

+! { 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

gcc/testsuite/gfortran.dg/associate_31.f90

+! { dg-do run }
+!
+! Test the fix for PR52832
+!
+! Contributed by Tobias Burnus  <burnus@gcc.gnu.org>
+!
+  subroutine testSub()
+    interface
+      integer function fcn1 (arg)
+        integer :: arg
+      end function
+      integer function fcn2 (arg)
+        integer :: arg
+      end function
+    end interface
+
+    procedure(fcn1), pointer :: r
+    r => fcn2
+    associate (k => r)
+      if (r(42) .ne. 84) call abort
+    end associate
+    r => fcn1
+    associate (k => r)
+      if (r(42) .ne. 42) call abort
+    end associate
+  end subroutine testSub
+
+  integer function fcn1 (arg)
+    integer :: arg;
+    fcn2 = arg
+  end function
+
+  integer function fcn2 (arg)
+    integer :: arg;
+    fcn2 = arg*2
+  end function
+
+  call testSub
+end