re PR fortran/31818 (Wrongly accepts namelists with assumed-shape arrays)

gcc/fortran:
2007-07-28  Daniel Franke  <franke.daniel@gmail.com>

	PR fortran/31818
	PR fortran/32876
	PR fortran/32905
	* gfortran.h (symbol_attribute): Added bits for pointer_comp, private_comp.
	* parse.c (parse_derived): Set pointer_comp/private_comp bits if the derived
	type ultimately contains pointer components or private components.
	* module.c (ab_attribute): New values AB_POINTER_COMP, AB_PRIVATE_COMP.
	(attr_bits): Added names for new ab_attributes.
	(mio_symbol_attribute): Save/restore new attribute bits in modules.
	* match.c (gfc_match_namelist): Removed check for namelist objects of assumed
	shape.
	* resolve.c (resolve_fl_namelist): Added check for pointer or private
	components in nested types. Added check for namelist objects of assumed
	shape.

gcc/testsuite:
2007-07-28  Daniel Franke  <franke.daniel@gmail.com>

	* gfortran.dg/namelist_5.f90: Adjusted error message.
	* gfortran.dg/assumed_shape_nml.f90: Renamed to ...
	* gfortran.dg/namelist_31.f90: ... this. Removed dg-warning directive.
	* gfortran.dg/assumed_size_nml.f90: Renamed to ...
	* gfortran.dg/namelist_32.f90: ... this.

	PR fortran/32876
	* gfortran.dg/namelist_33.f90: New test.

	PR fortran/32905
	* gfortran.dg/namelist_34.f90: New test.

	PR fortran/31818
	* gfortran.dg/namelist_35.f90: New test.

From-SVN: r127014

gcc/fortran/ChangeLog

+2007-07-28  Daniel Franke  <franke.daniel@gmail.com>
+
+	PR fortran/31818
+	PR fortran/32876
+	PR fortran/32905
+	* gfortran.h (symbol_attribute): Added bits for pointer_comp, private_comp.
+	* parse.c (parse_derived): Set pointer_comp/private_comp bits if the derived
+	type ultimately contains pointer components or private components.
+	* module.c (ab_attribute): New values AB_POINTER_COMP, AB_PRIVATE_COMP.
+	(attr_bits): Added names for new ab_attributes.
+	(mio_symbol_attribute): Save/restore new attribute bits in modules.
+	* match.c (gfc_match_namelist): Removed check for namelist objects of assumed
+	shape.
+	* resolve.c (resolve_fl_namelist): Added check for pointer or private
+	components in nested types. Added check for namelist objects of assumed
+	shape.
+
 2007-07-28  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/32880

gcc/fortran/gfortran.h

@@ -702,9 +702,9 @@ typedef struct
   /* Special attributes for Cray pointers, pointees.  */
   unsigned cray_pointer:1, cray_pointee:1;
 
-  /* The symbol is a derived type with allocatable components, possibly
-     nested.  */
-  unsigned alloc_comp:1;
+  /* The symbol is a derived type with allocatable components, pointer 
+     components or private components, possibly nested.  */
+  unsigned alloc_comp:1, pointer_comp:1, private_comp:1;
 
   /* The namespace where the VOLATILE attribute has been set.  */
   struct gfc_namespace *volatile_ns;

gcc/fortran/match.c

@@ -2822,12 +2822,6 @@ gfc_match_namelist (void)
 	      gfc_error_check ();
 	    }
 
-	  if (sym->as && sym->as->type == AS_ASSUMED_SHAPE
-	      && gfc_notify_std (GFC_STD_GNU, "Assumed shape array '%s' in "
-				 "namelist '%s' at %C is an extension.",
-				 sym->name, group_name->name) == FAILURE)
-	    gfc_error_check ();
-
 	  nl = gfc_get_namelist ();
 	  nl->sym = sym;
 	  sym->refs++;

gcc/fortran/module.c

@@ -1512,8 +1512,8 @@ typedef enum
   AB_IN_NAMELIST, AB_IN_COMMON, AB_FUNCTION, AB_SUBROUTINE, AB_SEQUENCE,
   AB_ELEMENTAL, AB_PURE, AB_RECURSIVE, AB_GENERIC, AB_ALWAYS_EXPLICIT,
   AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP,
-  AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_IS_BIND_C, AB_IS_C_INTEROP,
-  AB_IS_ISO_C
+  AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED,
+  AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C
 }
 ab_attribute;
 
@@ -1548,6 +1548,8 @@ static const mstring attr_bits[] =
     minit ("IS_ISO_C", AB_IS_ISO_C),
     minit ("VALUE", AB_VALUE),
     minit ("ALLOC_COMP", AB_ALLOC_COMP),
+    minit ("POINTER_COMP", AB_POINTER_COMP),
+    minit ("PRIVATE_COMP", AB_PRIVATE_COMP),
     minit ("PROTECTED", AB_PROTECTED),
     minit (NULL, -1)
 };
@@ -1654,6 +1656,10 @@ mio_symbol_attribute (symbol_attribute *attr)
 	MIO_NAME(ab_attribute) (AB_IS_ISO_C, attr_bits);
       if (attr->alloc_comp)
 	MIO_NAME (ab_attribute) (AB_ALLOC_COMP, attr_bits);
+      if (attr->pointer_comp)
+	MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits);
+      if (attr->private_comp)
+	MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits);
 
       mio_rparen ();
 
@@ -1760,6 +1766,12 @@ mio_symbol_attribute (symbol_attribute *attr)
 	    case AB_ALLOC_COMP:
 	      attr->alloc_comp = 1;
 	      break;
+	    case AB_POINTER_COMP:
+	      attr->pointer_comp = 1;
+	      break;
+	    case AB_PRIVATE_COMP:
+	      attr->private_comp = 1;
+	      break;
 	    }
 	}
     }

gcc/fortran/parse.c

@@ -1615,17 +1615,34 @@ parse_derived (void)
    */
   derived_sym = gfc_current_block();
 
-  /* Look for allocatable components.  */
   sym = gfc_current_block ();
   for (c = sym->components; c; c = c->next)
     {
+      /* Look for allocatable components.  */
       if (c->allocatable
 	  || (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp))
 	{
 	  sym->attr.alloc_comp = 1;
 	  break;
 	}
-     }
+
+      /* Look for pointer components.  */
+      if (c->pointer
+	  || (c->ts.type == BT_DERIVED && c->ts.derived->attr.pointer_comp))
+	{
+	  sym->attr.pointer_comp = 1;
+	  break;
+	}
+
+      /* Look for private components.  */
+      if (sym->component_access == ACCESS_PRIVATE
+	  || c->access == ACCESS_PRIVATE
+	  || (c->ts.type == BT_DERIVED && c->ts.derived->attr.private_comp))
+	{
+	  sym->attr.private_comp = 1;
+	  break;
+	}
+    }
 
   pop_state ();
 }

gcc/fortran/resolve.c

@@ -7027,45 +7027,75 @@ resolve_fl_namelist (gfc_symbol *sym)
     {
       for (nl = sym->namelist; nl; nl = nl->next)
 	{
-	  if (!nl->sym->attr.use_assoc
-	      && !(sym->ns->parent == nl->sym->ns)
-	      && !(sym->ns->parent
-		   && sym->ns->parent->parent == nl->sym->ns)
-	      && !gfc_check_access(nl->sym->attr.access,
-				   nl->sym->ns->default_access))
+	  if (nl->sym->attr.use_assoc
+	      || (sym->ns->parent == nl->sym->ns)
+	      || (sym->ns->parent
+		  && sym->ns->parent->parent == nl->sym->ns))
+	    continue;
+
+	  if (!gfc_check_access(nl->sym->attr.access,
+				nl->sym->ns->default_access))
 	    {
-	      gfc_error ("PRIVATE symbol '%s' cannot be member of "
-			 "PUBLIC namelist at %L", nl->sym->name,
-			 &sym->declared_at);
+	      gfc_error ("NAMELIST object '%s' was declared PRIVATE and "
+			 "cannot be member of PUBLIC namelist '%s' at %L",
+			 nl->sym->name, sym->name, &sym->declared_at);
+	      return FAILURE;
+	    }
+
+	  if (nl->sym->ts.type == BT_DERIVED
+	      && !gfc_check_access (nl->sym->ts.derived->attr.private_comp
+				    ? ACCESS_PRIVATE : ACCESS_UNKNOWN,
+				    nl->sym->ns->default_access))
+	    {
+	      gfc_error ("NAMELIST object '%s' has PRIVATE components and "
+			 "cannot be a member of PUBLIC namelist '%s' at %L",
+			 nl->sym->name, sym->name, &sym->declared_at);
 	      return FAILURE;
 	    }
 	}
     }
 
-  /* Reject namelist arrays that are not constant shape.  */
   for (nl = sym->namelist; nl; nl = nl->next)
     {
+      /* Reject namelist arrays of assumed shape.  */
+      if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE
+	  && gfc_notify_std (GFC_STD_F2003, "NAMELIST array object '%s' "
+			     "must not have assumed shape in namelist "
+			     "'%s' at %L", nl->sym->name, sym->name,
+			     &sym->declared_at) == FAILURE)
+	    return FAILURE;
+
+      /* Reject namelist arrays that are not constant shape.  */
       if (is_non_constant_shape_array (nl->sym))
 	{
-	  gfc_error ("The array '%s' must have constant shape to be "
-		     "a NAMELIST object at %L", nl->sym->name,
-		     &sym->declared_at);
+	  gfc_error ("NAMELIST array object '%s' must have constant "
+		     "shape in namelist '%s' at %L", nl->sym->name,
+		     sym->name, &sym->declared_at);
 	  return FAILURE;
 	}
-    }
 
-  /* Namelist objects cannot have allocatable components.  */
-  for (nl = sym->namelist; nl; nl = nl->next)
-    {
-      if (nl->sym->ts.type == BT_DERIVED
-	  && nl->sym->ts.derived->attr.alloc_comp)
+      /* Namelist objects cannot have allocatable or pointer components.  */
+      if (nl->sym->ts.type != BT_DERIVED)
+	continue;
+
+      if (nl->sym->ts.derived->attr.alloc_comp)
 	{
-	  gfc_error ("NAMELIST object '%s' at %L cannot have ALLOCATABLE "
-		     "components", nl->sym->name, &sym->declared_at);
+	  gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
+		     "have ALLOCATABLE components",
+		     nl->sym->name, sym->name, &sym->declared_at);
+	  return FAILURE;
+	}
+
+      if (nl->sym->ts.derived->attr.pointer_comp)
+	{
+	  gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
+		     "have POINTER components", 
+		     nl->sym->name, sym->name, &sym->declared_at);
 	  return FAILURE;
 	}
     }
 
+
   /* 14.1.2 A module or internal procedure represent local entities
      of the same type as a namelist member and so are not allowed.  */
   for (nl = sym->namelist; nl; nl = nl->next)

gcc/testsuite/ChangeLog

+2007-07-28  Daniel Franke  <franke.daniel@gmail.com>
+
+	* gfortran.dg/namelist_5.f90: Adjusted error message.
+	* gfortran.dg/assumed_shape_nml.f90: Renamed to ...
+	* gfortran.dg/namelist_31.f90: ... this. Removed dg-warning directive.
+	* gfortran.dg/assumed_size_nml.f90: Renamed to ...
+	* gfortran.dg/namelist_32.f90: ... this.
+
+	PR fortran/32876
+	* gfortran.dg/namelist_33.f90: New test.
+
+	PR fortran/32905
+	* gfortran.dg/namelist_34.f90: New test.
+
+	PR fortran/31818
+	* gfortran.dg/namelist_35.f90: New test.
+
 2007-07-28  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/32880

gcc/testsuite/gfortran.dg/assumed_shape_nml.f90 → gcc/testsuite/gfortran.dg/namelist_31.f90

@@ -10,8 +10,8 @@ program assumed_shape_nml
   call foo (z)
 contains
   subroutine foo (y)
-    real, DIMENSION (1:) :: y
-    namelist /mynml/ y     ! { dg-warning "is an extension" }
+    real, DIMENSION (:) :: y
+    namelist /mynml/ y
     write (*, mynml)
   end subroutine foo
 end program assumed_shape_nml

gcc/testsuite/gfortran.dg/namelist_33.f90

+! { dg-do compile }
+!
+! PR fortran/32876 - accepts private items in public NAMELISTs
+!
+MODULE types
+  type :: tp4
+    PRIVATE
+    real :: x
+    integer :: i
+  end type
+
+  ! nested type
+  type :: tp3
+    real :: x
+    integer, private :: i
+  end type
+
+  type :: tp2
+    type(tp3) :: t
+  end type
+
+  type :: tp1
+    integer :: i
+    type(tp2) :: t
+  end type
+END MODULE
+
+MODULE nml
+USE types
+   type(tp1) :: t1
+   type(tp4) :: t4
+
+   namelist /a/ t1    ! { dg-error "has PRIVATE components and cannot be a member of PUBLIC namelist" }
+   namelist /b/ t4    ! { dg-error "has PRIVATE components and cannot be a member of PUBLIC namelist" }
+
+  integer, private :: i
+  namelist /c/ i      ! { dg-error "was declared PRIVATE and cannot be member of PUBLIC namelist" }
+END MODULE
+
+! { dg-final { cleanup-modules "types nml" } }

gcc/testsuite/gfortran.dg/namelist_34.f90

+! { dg-do compile }
+!
+! PR fortran/32905 - accepts types with ultimate POINTER components
+!
+MODULE types
+  type :: tp3
+    real :: x
+    integer, pointer :: i
+  end type
+
+  type :: tp2
+    type(tp3) :: t
+  end type
+
+  type :: tp1
+    integer :: i
+    type(tp2) :: t
+  end type
+END MODULE
+
+MODULE nml
+USE types
+   type(tp1) :: t1
+   type(tp3) :: t3
+
+   namelist /a/ t1    ! { dg-error "cannot have POINTER components" }
+   namelist /b/ t3    ! { dg-error "cannot have POINTER components" }
+END MODULE
+
+! { dg-final { cleanup-modules "types nml" } }

gcc/testsuite/gfortran.dg/namelist_35.f90

+! { dg-do compile }
+! { dg-options "-std=f95" }
+!
+! PR fortran/31818 - accepts namelists with assumed-shape arrays
+!
+
+subroutine test(cha)
+  implicit none
+  character(len=10) :: cha(:)
+  namelist /z/  cha             ! { dg-error "must not have assumed shape" }
+end subroutine test

gcc/testsuite/gfortran.dg/namelist_5.f90

@@ -6,7 +6,7 @@
 !
 SUBROUTINE S1(I)
  integer :: a,b(I)
- NAMELIST /NLIST/ a,b ! { dg-error "must have constant shape to be a NAMELIST object" }
+ NAMELIST /NLIST/ a,b ! { dg-error "must have constant shape" }
  a=1 ; b=2
  write(6,NML=NLIST)
 END SUBROUTINE S1