[Patch, fortran] PR25054 - namelist objects with non-constant shape.

[Paul Thomas <paulthomas2 at wanadoo dot fr>]

:ADDPATCH fortran:

This is a "quickie" to cure PR25054 in which namelist objects with 
non-constant
shape were allowed.  This was accomplished by separating existing code to
detect non-constant shape arrays into a new function, which is called by
existing conditions as well as a loop through namelist objects.  I took the
opportunity to continue the spring-cleaning of resolve_symbol by lifting the
chunk of code dealing with FL_NAMELIST into its own function.

Regtested on FC3/Athlon: OK for trunk?

Paul


2006-02-15  Paul Thomas  <pault@gcc.gnu.org>

   PR fortran/25054
   * resolve.c (is_non_constant_shape_array): New function.
   (resolve_fl_variable): Remove code for the new function and call it.
   (resolve_fl_namelist): New function.  Add test for namelist array
   with non-constant shape, using is_non_constant_shape_array.
   (resolve_symbol): Remove code for resolve_fl_namelist and call it.

2006-02-15  Paul Thomas  <pault@gcc.gnu.org>

   PR fortran/25054
   * gfortran.dg/namelist_5.f90: New test.

Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 110986)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_charlen (gfc_charlen *cl)
*** 4598,4603 ****
--- 4598,4632 ----
  }
  
  
+ /* Test for non-constant shape arrays. */
+ 
+ static bool
+ is_non_constant_shape_array (gfc_symbol *sym)
+ {
+   gfc_expr *e;
+   int i;
+ 
+   if (sym->as != NULL)
+     {
+       /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
+ 	 has not been simplified; parameter array references.  Do the
+ 	 simplification now.  */
+       for (i = 0; i < sym->as->rank; i++)
+ 	{
+ 	  e = sym->as->lower[i];
+ 	  if (e && (resolve_index_expr (e) == FAILURE
+ 		|| !gfc_is_constant_expr (e)))
+ 	    return true;
+ 
+ 	  e = sym->as->upper[i];
+ 	  if (e && (resolve_index_expr (e) == FAILURE
+ 		|| !gfc_is_constant_expr (e)))
+ 	    return true;
+ 	}
+     }
+   return false;
+ }
+ 
  /* Resolution of common features of flavors variable and procedure. */
  
  static try
*************** resolve_fl_variable (gfc_symbol *sym, in
*** 4652,4694 ****
      return FAILURE;
  
    /* The shape of a main program or module array needs to be constant.  */
!   if (sym->as != NULL
! 	&& sym->ns->proc_name
  	&& (sym->ns->proc_name->attr.flavor == FL_MODULE
  	     || sym->ns->proc_name->attr.is_main_program)
  	&& !sym->attr.use_assoc
  	&& !sym->attr.allocatable
! 	&& !sym->attr.pointer)
      {
!       /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that
! 	 has not been simplified; parameter array references.  Do the
! 	 simplification now.  */
!       flag = 0;
!       for (i = 0; i < sym->as->rank; i++)
! 	{
! 	  e = sym->as->lower[i];
! 	  if (e && (resolve_index_expr (e) == FAILURE
! 		|| !gfc_is_constant_expr (e)))
! 	    {
! 	      flag = 1;
! 	      break;
! 	    }
! 
! 	  e = sym->as->upper[i];
! 	  if (e && (resolve_index_expr (e) == FAILURE
! 		|| !gfc_is_constant_expr (e)))
! 	    {
! 	      flag = 1;
! 	      break;
! 	    }
! 	}
! 
!       if (flag)
! 	{
! 	  gfc_error ("The module or main program array '%s' at %L must "
  		     "have constant shape", sym->name, &sym->declared_at);
  	  return FAILURE;
- 	}
      }
  
    if (sym->ts.type == BT_CHARACTER)
--- 4681,4697 ----
      return FAILURE;
  
    /* The shape of a main program or module array needs to be constant.  */
!   if (sym->ns->proc_name
  	&& (sym->ns->proc_name->attr.flavor == FL_MODULE
  	     || sym->ns->proc_name->attr.is_main_program)
  	&& !sym->attr.use_assoc
  	&& !sym->attr.allocatable
! 	&& !sym->attr.pointer
! 	&& is_non_constant_shape_array (sym))
      {
!        gfc_error ("The module or main program array '%s' at %L must "
  		     "have constant shape", sym->name, &sym->declared_at);
  	  return FAILURE;
      }
  
    if (sym->ts.type == BT_CHARACTER)
*************** resolve_fl_derived (gfc_symbol *sym)
*** 4961,4966 ****
--- 4964,5009 ----
  
  
  static try
+ resolve_fl_namelist (gfc_symbol *sym)
+ {
+   gfc_namelist *nl;
+ 
+   /* Reject PRIVATE objects in a PUBLIC namelist.  */
+   if (gfc_check_access(sym->attr.access, sym->ns->default_access))
+     {
+       for (nl = sym->namelist; nl; nl = nl->next)
+ 	{
+ 	  if (!nl->sym->attr.use_assoc
+ 		    &&
+ 		!(sym->ns->parent == nl->sym->ns)
+ 		    &&
+ 		 !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);
+ 	      return FAILURE;
+ 	    }
+ 	}
+     }
+ 
+     /* Reject namelist arrays that are not constant shape.  */
+     for (nl = sym->namelist; nl; nl = nl->next)
+       {
+ 	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);
+ 	    return FAILURE;
+ 	  }
+     }
+   return SUCCESS;
+ }
+ 
+ 
+ static try
  resolve_fl_parameter (gfc_symbol *sym)
  {
    /* A parameter array's shape needs to be constant.  */
*************** resolve_symbol (gfc_symbol * sym)
*** 5007,5013 ****
    /* Zero if we are checking a formal namespace.  */
    static int formal_ns_flag = 1;
    int formal_ns_save, check_constant, mp_flag;
-   gfc_namelist *nl;
    gfc_symtree *symtree;
    gfc_symtree *this_symtree;
    gfc_namespace *ns;
--- 5050,5055 ----
*************** resolve_symbol (gfc_symbol * sym)
*** 5162,5184 ****
        break;
  
      case FL_NAMELIST:
!       /* Reject PRIVATE objects in a PUBLIC namelist.  */
!       if (gfc_check_access(sym->attr.access, sym->ns->default_access))
! 	{
! 	  for (nl = sym->namelist; nl; nl = nl->next)
! 	    {
! 	      if (!nl->sym->attr.use_assoc
! 		    &&
! 		  !(sym->ns->parent == nl->sym->ns)
! 		    &&
! 		  !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);
! 	    }
! 	}
! 
        break;
  
      case FL_PARAMETER:
--- 5204,5211 ----
        break;
  
      case FL_NAMELIST:
!       if (resolve_fl_namelist (sym) == FAILURE)
! 	return;
        break;
  
      case FL_PARAMETER:
*************** resolve_symbol (gfc_symbol * sym)
*** 5192,5198 ****
        break;
      }
  
- 
    /* Make sure that intrinsic exist */
    if (sym->attr.intrinsic
        && ! gfc_intrinsic_name(sym->name, 0)
--- 5219,5224 ----

! { dg-do compile }
! Tests the fix for PR25054 in which namelist objects with non-constant
! shape were allowed.
!
! Contributed by Joost VandeVondele  <jv244@cam.ac.uk>
!
SUBROUTINE S1(I)
 integer :: a,b(I)
 NAMELIST /NLIST/ a,b
 a=1 ; b=2
 write(6,NML=NLIST) ! { dg-error "must have constant shape to be a NAMELIST object" }
END SUBROUTINE S1
END