re PR fortran/78659 ([F03] Spurious "requires DTIO" reported against namelist statement)

2017-05-11  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/78659
	* io.c (dtio_procs_present): Add new function to check for DTIO
	procedures relative to I/O statement READ or WRITE.
	(gfc_resolve_dt): Add namelist checks using the new function.
	* resolve.c (dtio_procs_present): Remove function and related
	namelist checks. (resolve_fl_namelist): Add check specific to
	Fortran 95 restriction on namelist objects.

	* gfortran.dg/namelist_91.f90: New test.
	* gfortran.dg/namelist_92.f90: New test.
	* gfortran.dg/namelist_93.f90: New test.
	* gfortran.dg/namelist_94.f90: New test.

From-SVN: r247930

gcc/fortran/ChangeLog

+2017-05-11  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/78659
+	* io.c (dtio_procs_present): Add new function to check for DTIO
+	procedures relative to I/O statement READ or WRITE.
+	(gfc_resolve_dt): Add namelist checks using the new function.
+	* resolve.c (dtio_procs_present): Remove function and related
+	namelist checks. (resolve_fl_namelist): Add check specific to
+	Fortran 95 restriction on namelist objects.
+
 2017-05-11  Nathan Sidwell  <nathan@acm.org>
 	
 	* trans-decl.c: Include dumpfile.h not tree-dump.h,

gcc/fortran/io.c

@@ -2966,6 +2966,30 @@ conflict:
   return MATCH_ERROR;
 }
 
+/* Check for formatted read and write DTIO procedures.  */
+
+static bool
+dtio_procs_present (gfc_symbol *sym, io_kind k)
+{
+  gfc_symbol *derived;
+
+  if (sym && sym->ts.u.derived)
+    {
+      if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
+	derived = CLASS_DATA (sym)->ts.u.derived;
+      else if (sym->ts.type == BT_DERIVED)
+	derived = sym->ts.u.derived;
+      else
+	return false;
+      if ((k == M_WRITE || k == M_PRINT) && 
+	  (gfc_find_specific_dtio_proc (derived, true, true) != NULL))
+	return true;
+      if ((k == M_READ) &&
+	  (gfc_find_specific_dtio_proc (derived, false, true) != NULL))
+	return true;
+    }
+  return false;
+}
 
 /* Traverse a namelist that is part of a READ statement to make sure
    that none of the variables in the namelist are INTENT(IN).  Returns
@@ -3244,7 +3268,7 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc)
 
   /* If we are reading and have a namelist, check that all namelist symbols
      can appear in a variable definition context.  */
-  if (k == M_READ && dt->namelist)
+  if (dt->namelist)
     {
       gfc_namelist* n;
       for (n = dt->namelist->namelist; n; n = n->next)
@@ -3252,17 +3276,50 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc)
 	  gfc_expr* e;
 	  bool t;
 
-	  e = gfc_get_variable_expr (gfc_find_sym_in_symtree (n->sym));
-	  t = gfc_check_vardef_context (e, false, false, false, NULL);
-	  gfc_free_expr (e);
+	  if (k == M_READ)
+	    {
+	      e = gfc_get_variable_expr (gfc_find_sym_in_symtree (n->sym));
+	      t = gfc_check_vardef_context (e, false, false, false, NULL);
+	      gfc_free_expr (e);
+    
+	      if (!t)
+		{
+		  gfc_error ("NAMELIST %qs in READ statement at %L contains"
+			     " the symbol %qs which may not appear in a"
+			     " variable definition context",
+			     dt->namelist->name, loc, n->sym->name);
+		  return false;
+		}
+	    }
+
+	  t = dtio_procs_present (n->sym, k);
 
-	  if (!t)
+	  if (n->sym->ts.type == BT_CLASS && !t)
 	    {
-	      gfc_error ("NAMELIST %qs in READ statement at %L contains"
-			 " the symbol %qs which may not appear in a"
-			 " variable definition context",
-			 dt->namelist->name, loc, n->sym->name);
-	      return false;
+	      gfc_error ("NAMELIST object %qs in namelist %qs at %L is "
+			 "polymorphic and requires a defined input/output "
+			 "procedure", n->sym->name, dt->namelist->name, loc);
+	      return 1;
+	    }
+    
+	  if ((n->sym->ts.type == BT_DERIVED)
+	      && (n->sym->ts.u.derived->attr.alloc_comp
+		  || n->sym->ts.u.derived->attr.pointer_comp))
+	    {
+	      if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in "
+				   "namelist %qs at %L with ALLOCATABLE "
+				   "or POINTER components", n->sym->name,
+				   dt->namelist->name, loc))
+		return 1;
+    
+	      if (!t)
+		{
+		  gfc_error ("NAMELIST object %qs in namelist %qs at %L has "
+			     "ALLOCATABLE or POINTER components and thus requires "
+			     "a defined input/output procedure", n->sym->name,
+			     dt->namelist->name, loc);
+		  return 1;
+		}
 	    }
 	}
     }

gcc/fortran/resolve.c

@@ -13846,31 +13846,11 @@ resolve_fl_derived (gfc_symbol *sym)
 }
 
 
-/* Check for formatted read and write DTIO procedures.  */
-
-static bool
-dtio_procs_present (gfc_symbol *sym)
-{
-  gfc_symbol *derived;
-
-  if (sym->ts.type == BT_CLASS)
-    derived = CLASS_DATA (sym)->ts.u.derived;
-  else if (sym->ts.type == BT_DERIVED)
-    derived = sym->ts.u.derived;
-  else
-    return false;
-
-  return gfc_find_specific_dtio_proc (derived, true, true) != NULL
-	 && gfc_find_specific_dtio_proc (derived, false, true) != NULL;
-}
-
-
 static bool
 resolve_fl_namelist (gfc_symbol *sym)
 {
   gfc_namelist *nl;
   gfc_symbol *nlsym;
-  bool dtio;
 
   for (nl = sym->namelist; nl; nl = nl->next)
     {
@@ -13904,27 +13884,6 @@ resolve_fl_namelist (gfc_symbol *sym)
 			      sym->name, &sym->declared_at))
 	return false;
 
-      dtio = dtio_procs_present (nl->sym);
-
-      if (nl->sym->ts.type == BT_CLASS && !dtio)
-	{
-	  gfc_error ("NAMELIST object %qs in namelist %qs at %L is "
-		     "polymorphic and requires a defined input/output "
-		     "procedure", nl->sym->name, sym->name, &sym->declared_at);
-	  return false;
-	}
-
-      if (nl->sym->ts.type == BT_DERIVED
-	  && (nl->sym->ts.u.derived->attr.alloc_comp
-	      || nl->sym->ts.u.derived->attr.pointer_comp))
-	{
-	  if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in "
-			       "namelist %qs at %L with ALLOCATABLE "
-			       "or POINTER components", nl->sym->name,
-			       sym->name, &sym->declared_at))
-	    return false;
-	  return true;
-	}
     }
 
   /* Reject PRIVATE objects in a PUBLIC namelist.  */
@@ -13942,10 +13901,17 @@ resolve_fl_namelist (gfc_symbol *sym)
 	      return false;
 	    }
 
-	  /* If the derived type has specific DTIO procedures for both read and
-	     write then namelist objects with private components are OK.  */
-	  if (dtio_procs_present (nl->sym))
-	    continue;
+	  if (nl->sym->ts.type == BT_DERIVED
+	     && (nl->sym->ts.u.derived->attr.alloc_comp
+		 || nl->sym->ts.u.derived->attr.pointer_comp))
+	   {
+	     if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in "
+				  "namelist %qs at %L with ALLOCATABLE "
+				  "or POINTER components", nl->sym->name,
+				  sym->name, &sym->declared_at))
+	       return false;
+	     return true;
+	   }
 
 	  /* Types with private components that came here by USE-association.  */
 	  if (nl->sym->ts.type == BT_DERIVED

gcc/testsuite/ChangeLog

+2017-05-11  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/78659
+	* gfortran.dg/namelist_91.f90: New test.
+	* gfortran.dg/namelist_92.f90: New test.
+	* gfortran.dg/namelist_93.f90: New test.
+	* gfortran.dg/namelist_94.f90: New test.
+
 2017-05-11  Bill Schmidt  <wschmidt@linux.vnet.ibm.com>
 
 	PR target/80695

gcc/testsuite/gfortran.dg/namelist_91.f90

+! { dg-do compile }
+! PR78659 Spurious "requires DTIO" reported against namelist statement
+program p
+   type t
+     integer :: k
+   end type
+   class(t), allocatable :: x
+   namelist /nml/ x
+end

gcc/testsuite/gfortran.dg/namelist_92.f90

+! { dg-do compile }
+! PR78659 Spurious "requires DTIO" reported against namelist statement
+MODULE ma
+  IMPLICIT NONE
+  TYPE :: ta
+    INTEGER, allocatable :: array(:)
+  END TYPE ta
+END MODULE ma
+
+PROGRAM p
+  USE ma
+  type(ta):: x
+  NAMELIST /nml/ x
+  WRITE (*, nml) ! { dg-error "has ALLOCATABLE or POINTER components and thus requires a defined input/output" }
+  READ (*, nml) ! { dg-error "has ALLOCATABLE or POINTER components and thus requires a defined input/output" }
+END PROGRAM p

gcc/testsuite/gfortran.dg/namelist_93.f90

+! { dg-do compile }
+! PR78659 Spurious "requires DTIO" reported against namelist statement
+MODULE ma
+  IMPLICIT NONE
+  TYPE :: ta
+    INTEGER, allocatable :: array(:)
+  END TYPE ta
+END MODULE ma
+
+PROGRAM p
+  USE ma
+  class(ta), allocatable :: x
+  NAMELIST /nml/ x
+  WRITE (*, nml)! { dg-error "is polymorphic and requires a defined input/output procedure" }
+  READ (*, nml) ! { dg-error "is polymorphic and requires a defined input/output procedure" }
+END PROGRAM p

gcc/testsuite/gfortran.dg/namelist_94.f90

+! { dg-do compile }
+! PR78659 Spurious "requires DTIO" reported against namelist statement
+MODULE m
+  IMPLICIT NONE
+  TYPE :: t
+    CHARACTER :: c
+  CONTAINS
+    PROCEDURE :: write_formatted
+    GENERIC :: WRITE(FORMATTED) => write_formatted
+  END TYPE
+CONTAINS
+  SUBROUTINE write_formatted(dtv, unit, iotype, v_list, iostat, iomsg)
+    CLASS(t), INTENT(IN) :: dtv
+    INTEGER, INTENT(IN) :: unit
+    CHARACTER(*), INTENT(IN) :: iotype
+    INTEGER, INTENT(IN) :: v_list(:)
+    INTEGER, INTENT(OUT) :: iostat
+    CHARACTER(*), INTENT(INOUT) :: iomsg
+    WRITE (unit, "(A)", IOSTAT=iostat, IOMSG=iomsg) dtv%c
+    print *, "what"
+  END SUBROUTINE
+END MODULE
+
+PROGRAM p
+  USE m
+  IMPLICIT NONE
+  class(t), allocatable :: x
+  NAMELIST /nml/ x
+  x = t('a')
+  WRITE (*, nml)
+  READ (*, nml) ! { dg-error "is polymorphic and requires a defined input/output procedure" }
+END