re PR fortran/82173 ([meta-bug] Parameterized derived type errors)

2017-09-17  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/82173
	* decl.c (gfc_get_pdt_instance): Use the component initializer
	expression for the default, rather than the parameter value.
	* resolve.c (resolve_pdt): New function.
	(resolve_symbol): Call it. Remove false error, prohibiting
	deferred type parameters for dummy arguments.

	PR fortran/60483
	* primary.c (gfc_match_varspec): If the type of an associate
	name is unknown and yet there is a match, try resolving the
	target expression and using its type.

2017-09-17  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/82173
	* gfortran.dg/pdt_1.f03 : Eliminate spurious error checks.
	* gfortran.dg/pdt_2.f03 : The same.
	* gfortran.dg/pdt_3.f03 : The same.
	* gfortran.dg/pdt_4.f03 : Add 'modtype' and two new errors in
	module 'bad_vars'. Add error concerning assumed parameters and
	save attribute.
	* gfortran.dg/pdt_11.f03 : New test.

	PR fortran/60483
	* gfortran.dg/associate_9.f90 : Remove XFAIL and change to run.
	* gfortran.dg/associate_25.f90 : New test.
	* gfortran.dg/pdt_12.f03 : New test.

From-SVN: r252894

gcc/fortran/ChangeLog

+2017-09-17  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/82173
+	* decl.c (gfc_get_pdt_instance): Use the component initializer
+	expression for the default, rather than the parameter value.
+	* resolve.c (resolve_pdt): New function.
+	(resolve_symbol): Call it. Remove false error, prohibiting
+	deferred type parameters for dummy arguments.
+
+	PR fortran/60483
+	* primary.c (gfc_match_varspec): If the type of an associate
+	name is unknown and yet there is a match, try resolving the
+	target expression and using its type.
+
 2017-09-15  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/82184

gcc/fortran/decl.c

@@ -3275,8 +3275,8 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
 	    kind_expr = gfc_copy_expr (actual_param->expr);
 	  else
 	    {
-	      if (param->value)
-		kind_expr = gfc_copy_expr (param->value);
+	      if (c1->initializer)
+		kind_expr = gfc_copy_expr (c1->initializer);
 	      else if (!(actual_param && param->attr.pdt_len))
 		{
 		  gfc_error ("The derived parameter '%qs' at %C does not "

gcc/fortran/primary.c

@@ -2055,10 +2055,21 @@ 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.  */
   if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES)
     {
-      gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym->name);
-      return MATCH_ERROR;
+      if (sym->assoc && sym->assoc->target)
+	{
+	  gfc_resolve_expr (sym->assoc->target);
+	  sym->ts = sym->assoc->target->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)

gcc/fortran/resolve.c

@@ -14125,6 +14125,57 @@ resolve_fl_parameter (gfc_symbol *sym)
 }
 
 
+/* Called by resolve_symbol to chack PDTs.  */
+
+static void
+resolve_pdt (gfc_symbol* sym)
+{
+  gfc_symbol *derived = NULL;
+  gfc_actual_arglist *param;
+  gfc_component *c;
+  bool const_len_exprs = true;
+  bool assumed_len_exprs = false;
+
+  if (sym->ts.type == BT_DERIVED)
+    derived = sym->ts.u.derived;
+  else if (sym->ts.type == BT_CLASS)
+    derived = CLASS_DATA (sym)->ts.u.derived;
+  else
+    gcc_unreachable ();
+
+  gcc_assert (derived->attr.pdt_type);
+
+  for (param = sym->param_list; param; param = param->next)
+    {
+      c = gfc_find_component (derived, param->name, false, true, NULL);
+      gcc_assert (c);
+      if (c->attr.pdt_kind)
+	continue;
+
+      if (param->expr && !gfc_is_constant_expr (param->expr)
+	  && c->attr.pdt_len)
+	const_len_exprs = false;
+      else if (param->spec_type == SPEC_ASSUMED)
+	assumed_len_exprs = true;
+    }
+
+  if (!const_len_exprs
+      && (sym->ns->proc_name->attr.is_main_program
+	  || sym->ns->proc_name->attr.flavor == FL_MODULE
+	  || sym->attr.save != SAVE_NONE))
+    gfc_error ("The AUTOMATIC object %qs at %L must not have the "
+	       "SAVE attribute or be a variable declared in the "
+	       "main program, a module or a submodule(F08/C513)",
+	       sym->name, &sym->declared_at);
+
+  if (assumed_len_exprs && !(sym->attr.dummy
+      || sym->attr.select_type_temporary || sym->attr.associate_var))
+    gfc_error ("The object %qs at %L with ASSUMED type parameters "
+	       "must be a dummy or a SELECT TYPE selector(F08/4.2)",
+	       sym->name, &sym->declared_at);
+}
+
+
 /* Do anything necessary to resolve a symbol.  Right now, we just
    assume that an otherwise unknown symbol is a variable.  This sort
    of thing commonly happens for symbols in module.  */
@@ -14381,15 +14432,6 @@ resolve_symbol (gfc_symbol *sym)
       return;
     }
 
-  if (sym->attr.dummy && sym->ts.type == BT_DERIVED
-      && sym->ts.u.derived->attr.pdt_type
-      && gfc_spec_list_type (sym->param_list, NULL) == SPEC_DEFERRED)
-    {
-      gfc_error ("%qs at %L cannot have DEFERRED type parameters because "
-		 "it is a dummy argument", sym->name, &sym->declared_at);
-      return;
-    }
-
   if (sym->attr.value && sym->ts.type == BT_CHARACTER)
     {
       gfc_charlen *cl = sym->ts.u.cl;
@@ -14927,6 +14969,9 @@ resolve_symbol (gfc_symbol *sym)
       || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function))
     if (!resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name))
       return;
+
+  if (sym->param_list)
+    resolve_pdt (sym);
 }
 
 

gcc/testsuite/ChangeLog

+2017-09-17  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/82173
+	* gfortran.dg/pdt_1.f03 : Eliminate spurious error checks.
+	* gfortran.dg/pdt_2.f03 : The same.
+	* gfortran.dg/pdt_3.f03 : The same.
+	* gfortran.dg/pdt_4.f03 : Add 'modtype' and two new errors in
+	module 'bad_vars'. Add error concerning assumed parameters and
+	save attribute.
+	* gfortran.dg/pdt_11.f03 : New test.
+
+	PR fortran/60483
+	* gfortran.dg/associate_9.f90 : Remove XFAIL and change to run.
+	* gfortran.dg/associate_25.f90 : New test.
+	* gfortran.dg/pdt_12.f03 : New test.
+
 2017-09-15  Andrew Sutton  <andrew.n.sutton@gmail.com>
 	    Jakub Jelinek  <jakub@redhat.com>
 

gcc/testsuite/gfortran.dg/associate_25.f90

+! { dg-do run }
+!
+! Checks the fix for PR60483.
+!
+! Contributed by Anthony Lewis  <antony@cosmologist.info>
+!
+module A
+  implicit none
+  Type T
+    integer :: val = 2
+  contains
+    final :: testfree
+  end type
+  integer :: final_flag = 0
+contains
+  subroutine testfree(this)
+    Type(T) this
+    final_flag = this%val + final_flag
+  end subroutine
+  subroutine Testf()
+    associate(X => T()) ! This was failing: Symbol 'x' at (1) has no IMPLICIT type
+      final_flag = X%val
+    end associate
+! This should now be 4 but the finalization is not happening.
+! TODO put it right!
+    if (final_flag .ne. 2) call abort
+  end subroutine Testf
+end module
+
+  use A
+  call Testf
+end

gcc/testsuite/gfortran.dg/associate_9.f03

-! { dg-do compile }
+! { dg-do run }
 ! { 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
@@ -46,5 +45,3 @@ PROGRAM main
     IF (x%comp /= 10) CALL abort ()
   END ASSOCIATE
 END PROGRAM main
-
-! { dg-excess-errors "Syntex error in IF" }

gcc/testsuite/gfortran.dg/pdt_1.f03

@@ -21,7 +21,7 @@
   end type
 
   type(mytype(b=4)) :: z(2)
-  type(mytype(ftype, pdt_len)) :: z2
+  type(mytype(ftype, 4)) :: z2
 
   z(1)%i = 1
   z(2)%i = 2

gcc/testsuite/gfortran.dg/pdt_11.f03

+! { dg-do run }
+!
+! Rolls together 'len_par_06_pos.f90' and 'len_par_07_pos.f90', both of which
+! failed to compile.
+!
+! Contributed by Reinhold Bader  <reinhold.bader@lrz.de>
+!
+module m_type_decs
+
+  implicit none
+
+  type :: matrix(rk, n, m)
+     integer, kind :: rk
+     integer, len :: n = 15, m = 20
+     real(rk) :: entry(n, m)
+  end type matrix
+
+  type :: fdef(rk, n)
+     integer, kind :: rk = kind(1.0)
+     integer, len :: n = 15
+  end type
+
+end module
+
+program test
+
+  use m_type_decs
+  implicit none
+  integer, parameter :: rk1=kind(1.d0)
+  type(matrix(rk1,:,:)), allocatable :: o_matrix
+  type(fdef(n=:)), allocatable :: o_fdef
+
+  allocate(matrix(rk=rk1)::o_matrix)
+
+  if (o_matrix%n == 15 .and. o_matrix%m == 20) then
+     write(*,*) 'o_matrix OK'
+  else
+     write(*,*) 'o_matrix FAIL'
+     call abort
+  end if
+
+  allocate(fdef(n=12)::o_fdef)
+
+  if (o_fdef%n == 12) then
+     write(*,*) 'o_fdef OK'
+  else
+     write(*,*) 'o_fdef FAIL'
+     call abort
+  end if
+end program test
+
+

gcc/testsuite/gfortran.dg/pdt_12.f03

+! { dg-do run }
+!
+! Checks PDTs with ASSOCIATE.
+! Was failing for same reason as PR60483.
+!
+! Contributed by Reinhold Bader  <reinhold.bader@lrz.de>
+!
+module matrix_mod_assumed_05
+
+  implicit none
+
+  type :: matrix(rk, n, m)
+     integer, kind :: rk
+     integer, len :: n, m
+     real(rk) :: entry(n, m)
+  end type matrix
+  integer, parameter :: rk=kind(1.d0)
+  integer :: mm=20, nn=15
+
+contains
+  function factory()
+    type(matrix(rk, :, :)), allocatable :: factory
+    allocate(matrix(rk, nn, mm) :: factory)
+  end function
+end module
+
+program test
+
+  use matrix_mod_assumed_05
+  implicit none
+
+  associate (o_matrix => factory())
+    if (o_matrix%n == nn .and. o_matrix%m == mm) then  ! Symbol 'o_matrix' at (1) has no IMPLICIT type
+     write(*,*) 'OK'
+    else
+     write(*,*) 'FAIL'
+     call abort
+    end if
+  end associate
+
+end program test
+

gcc/testsuite/gfortran.dg/pdt_2.f03

@@ -7,7 +7,6 @@
 !
   implicit none
   integer, parameter :: ftype = kind(0.0e0)
-  integer :: pdt_len = 4
   integer :: i
   type :: mytype (a,b)
     integer, kind :: a = kind(0.0d0)
@@ -17,7 +16,7 @@
     character (len = b*b) :: chr
   end type
 
-  type(mytype(ftype, pdt_len)) :: z2
+  type(mytype(ftype, 4)) :: z2
   call foobar (z2)
 contains
   subroutine foobar (arg)

gcc/testsuite/gfortran.dg/pdt_3.f03

@@ -34,7 +34,7 @@ end module
 
   real, allocatable :: matrix (:,:)
   type(thytype(ftype, 4, 4)) :: w
-  type(x(8,4,mat_dim)) :: q
+  type(x(8,4,256)) :: q
   class(mytype(ftype, :)), allocatable :: cz
 
   w%d = reshape ([(real(i), i = 1, d_dim*d_dim)],[d_dim,d_dim])

gcc/testsuite/gfortran.dg/pdt_4.f03

@@ -2,13 +2,25 @@
 !
 ! Test bad PDT coding: Based on pdt_3.f03
 !
-module vars
+module m
   integer :: d_dim = 4
   integer :: mat_dim = 256
   integer, parameter :: ftype = kind(0.0d0)
+  type :: modtype (a,b)
+    integer, kind :: a = kind(0.0e0)
+    integer, LEN :: b = 4
+    integer :: i
+    real(kind = a) :: d(b, b)
+  end type
+end module
+
+module bad_vars
+  use m
+  type(modtype(8,mat_dim)) :: mod_q ! { dg-error "must not have the SAVE attribute" }
+  type(modtype(8,*)) :: mod_r       ! { dg-error "ASSUMED type parameters" }
 end module
 
-  use vars
+  use m
   implicit none
   integer :: i
   integer, kind :: bad_kind    ! { dg-error "not allowed outside a TYPE definition" }
@@ -50,7 +62,7 @@ end module
   type(thytype(:, 4, 4)) :: w_ugh    ! { dg-error "cannot either be ASSUMED or DEFERRED" }
 
   type(thytype(ftype, b=4, h=4)) :: w
-  type(x(8,4,mat_dim)) :: q
+  type(x(8,4,mat_dim)) :: q          ! { dg-error "must not have the SAVE attribute" }
   class(mytype(ftype, :)), allocatable :: cz
 
   w%a = 1                           ! { dg-error "assignment to a KIND or LEN component" }
@@ -82,9 +94,9 @@ end module
   deallocate (cz)
 contains
   subroutine foo(arg)
-    type (mytype(4, *)) :: arg      ! used to have an invalid "is being used before it is defined"
+    type (mytype(4, *)) :: arg      ! OK
   end subroutine
-  subroutine bar(arg)               ! { dg-error "cannot have DEFERRED type parameters" }
+  subroutine bar(arg)               ! OK
     type (thytype(8, :, 4) :: arg
   end subroutine
 end