re PR fortran/47339 (Fortran 2003/2008: Valid NAMELIST rejected; Fortran 95: Invalid namelist objects accepted)

2011-01-26  Tobias Burnus  <burnus@net-b.de>

        PR fortran/47339
        PR fortran/43062
        * match.c (gfc_match_namelist): Allow assumed-length characters.
        * resolve.c (resolve_fl_namelist): Adapt and add error messages.
        * symbol.c (check_conflict): Allow allocatables in NML for
        * F2003.
        * trans-io.c (nml_get_addr_expr,transfer_namelist_element):
        Changes due to that change.

2011-01-26  Tobias Burnus  <burnus@net-b.de>

        PR fortran/47339
        PR fortran/43062
        * fortran.dg/namelist_69.f90: New test.
        * fortran.dg/namelist_70.f90: New test.
        * fortran.dg/namelist_assumed_char.f90: Modify dg-error, augment
        * test.
        * fortran.dg/namelist_3.f90: Adapt test.
        * fortran.dg/namelist_34.f90: Ditto.
        * fortran.dg/namelist_35.f90: Ditto.
        * fortran.dg/namelist_5.f90: Ditto.
        * fortran.dg/namelist_63.f90: Ditto.
        * gfortran.dg/alloc_comp_constraint_1.f90: Ditto.

From-SVN: r169282

4 files changed, 78 insertions, 66 deletions

diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 70f5862..0793b8c 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -4030,13 +4030,6 @@ gfc_match_namelist (void)
 	      gfc_error_check ();
 	    }
 
-	  if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl->length == NULL)
-	    {
-	      gfc_error ("Assumed character length '%s' in namelist '%s' at "
-			 "%C is not allowed", sym->name, group_name->name);
-	      gfc_error_check ();
-	    }
-
 	  nl = gfc_get_namelist ();
 	  nl->sym = sym;
 	  sym->refs++;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 9f0d675..a4a77ac 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -11726,40 +11726,64 @@ resolve_fl_namelist (gfc_symbol *sym)
 
   for (nl = sym->namelist; nl; nl = nl->next)
     {
-      /* Reject namelist arrays of assumed shape.  */
+      /* Check again, the check in match only works if NAMELIST comes
+	 after the decl.  */
+      if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
+     	{
+	  gfc_error ("Assumed size array '%s' in namelist '%s' at %L is not "
+		     "allowed", nl->sym->name, sym->name, &sym->declared_at);
+	  return FAILURE;
+	}
+
       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 "
+	  && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: NAMELIST array "
+			     "object '%s' with assumed shape in namelist "
 			     "'%s' at %L", nl->sym->name, sym->name,
 			     &sym->declared_at) == FAILURE)
-	    return FAILURE;
+	return FAILURE;
 
-      /* Reject namelist arrays that are not constant shape.  */
-      if (is_non_constant_shape_array (nl->sym))
-	{
-	  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;
-	}
+      if (is_non_constant_shape_array (nl->sym)
+	  && gfc_notify_std (GFC_STD_F2003,  "Fortran 2003: NAMELIST array "
+			     "object '%s' with nonconstant shape in namelist "
+			     "'%s' at %L", nl->sym->name, sym->name,
+			     &sym->declared_at) == FAILURE)
+	return FAILURE;
 
-      /* Namelist objects cannot have allocatable or pointer components.  */
-      if (nl->sym->ts.type != BT_DERIVED)
-	continue;
+      if (nl->sym->ts.type == BT_CHARACTER
+	  && (nl->sym->ts.u.cl->length == NULL
+	      || !gfc_is_constant_expr (nl->sym->ts.u.cl->length))
+	  && gfc_notify_std (GFC_STD_F2003,  "Fortran 2003: NAMELIST object "
+			     "'%s' with nonconstant character length in "
+			     "namelist '%s' at %L", nl->sym->name, sym->name,
+			     &sym->declared_at) == FAILURE)
+	return FAILURE;
 
-      if (nl->sym->ts.u.derived->attr.alloc_comp)
+      /* FIXME: Once UDDTIO is implemented, the following can be
+	 removed.  */
+      if (nl->sym->ts.type == BT_CLASS)
 	{
-	  gfc_error ("NAMELIST object '%s' in namelist '%s' at %L cannot "
-		     "have ALLOCATABLE components",
-		     nl->sym->name, sym->name, &sym->declared_at);
+	  gfc_error ("NAMELIST object '%s' in namelist '%s' at %L is "
+		     "polymorphic and requires a defined input/output "
+		     "procedure", nl->sym->name, sym->name, &sym->declared_at);
 	  return FAILURE;
 	}
 
-      if (nl->sym->ts.u.derived->attr.pointer_comp)
+      if (nl->sym->ts.type == BT_DERIVED
+	  && (nl->sym->ts.u.derived->attr.alloc_comp
+	      || nl->sym->ts.u.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);
+	  if (gfc_notify_std (GFC_STD_F2003,  "Fortran 2003: NAMELIST object "
+			      "'%s' in namelist '%s' at %L with ALLOCATABLE "
+			      "or POINTER components", nl->sym->name,
+			      sym->name, &sym->declared_at) == FAILURE)
+	    return FAILURE;
+
+	 /* FIXME: Once UDDTIO is implemented, the following can be
+	    removed.  */
+	  gfc_error ("NAMELIST object '%s' in namelist '%s' at %L has "
+		     "ALLOCATABLE or POINTER components and thus requires "
+		     "a defined input/output procedure", nl->sym->name,
+		     sym->name, &sym->declared_at);
 	  return FAILURE;
 	}
     }
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index cb5a08f..71aa518 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -390,6 +390,14 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
       goto conflict_std;
     }
 
+  if (attr->in_namelist && (attr->allocatable || attr->pointer))
+    {
+      a1 = in_namelist;
+      a2 = attr->allocatable ? allocatable : pointer;
+      standard = GFC_STD_F2003;
+      goto conflict_std;
+    }
+
   /* Check for attributes not allowed in a BLOCK DATA.  */
   if (gfc_current_state () == COMP_BLOCK_DATA)
     {
@@ -495,9 +503,6 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where)
   conf (in_equivalence, allocatable);
   conf (in_equivalence, threadprivate);
 
-  conf (in_namelist, pointer);
-  conf (in_namelist, allocatable);
-
   conf (entry, result);
 
   conf (function, subroutine);
diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index 04ad870..f6a783f 100644
--- a/gcc/fortran/trans-io.c
+++ b/gcc/fortran/trans-io.c
@@ -1463,6 +1463,7 @@ nml_full_name (const char* var_name, const char* cmp_name)
   return full_name;
 }
 
+
 /* nml_get_addr_expr builds an address expression from the
    gfc_symbol or gfc_component backend_decl's. An offset is
    provided so that the address of an element of an array of
@@ -1475,9 +1476,6 @@ nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
 {
   tree decl = NULL_TREE;
   tree tmp;
-  tree itmp;
-  int array_flagged;
-  int dummy_arg_flagged;
 
   if (sym)
     {
@@ -1503,18 +1501,8 @@ nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
 
   /* Build indirect reference, if dummy argument.  */
 
-  dummy_arg_flagged = POINTER_TYPE_P (TREE_TYPE(tmp));
-
-  itmp = (dummy_arg_flagged) ? build_fold_indirect_ref_loc (input_location,
-							tmp) : tmp;
-
-  /* If an array, set flag and use indirect ref. if built.  */
-
-  array_flagged = (TREE_CODE (TREE_TYPE (itmp)) == ARRAY_TYPE
-		   && !TYPE_STRING_FLAG (TREE_TYPE (itmp)));
-
-  if (array_flagged)
-    tmp = itmp;
+  if (POINTER_TYPE_P (TREE_TYPE(tmp)))
+    tmp = build_fold_indirect_ref_loc (input_location, tmp);
 
   /* Treat the component of a derived type, using base_addr for
      the derived type.  */
@@ -1523,29 +1511,27 @@ nml_get_addr_expr (gfc_symbol * sym, gfc_component * c,
     tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
 			   base_addr, tmp, NULL_TREE);
 
-  /* If we have a derived type component, a reference to the first
-     element of the array is built.  This is done so that base_addr,
-     used in the build of the component reference, always points to
-     a RECORD_TYPE.  */
-
-  if (array_flagged)
-    tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
-
-  /* Now build the address expression.  */
-
-  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+    tmp = gfc_conv_array_data (tmp);
+  else
+    {
+      if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+	tmp = gfc_build_addr_expr (NULL_TREE, tmp);
 
-  /* If scalar dummy, resolve indirect reference now.  */
+      if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
+         tmp = gfc_build_array_ref (tmp, gfc_index_zero_node, NULL);
 
-  if (dummy_arg_flagged && !array_flagged)
-    tmp = build_fold_indirect_ref_loc (input_location,
+      if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+	tmp = build_fold_indirect_ref_loc (input_location,
 				   tmp);
+    }
 
   gcc_assert (tmp && POINTER_TYPE_P (TREE_TYPE (tmp)));
 
   return tmp;
 }
 
+
 /* For an object VAR_NAME whose base address is BASE_ADDR, generate a
    call to iocall[IOCALL_SET_NML_VAL].  For derived type variable, recursively
    generate calls to iocall[IOCALL_SET_NML_VAL] for each component.  */
@@ -1565,6 +1551,7 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
   tree tmp;
   tree dtype;
   tree dt_parm_addr;
+  tree decl = NULL_TREE;
   int n_dim; 
   int itype;
   int rank = 0;
@@ -1588,7 +1575,10 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
 
   if (rank)
     {
-      dt =  TREE_TYPE ((sym) ? sym->backend_decl : c->backend_decl);
+      decl = (sym) ? sym->backend_decl : c->backend_decl;
+      if (sym && sym->attr.dummy)
+        decl = build_fold_indirect_ref_loc (input_location, decl);
+      dt =  TREE_TYPE (decl);
       dtype = gfc_get_dtype (dt);
     }
   else
@@ -1622,9 +1612,9 @@ transfer_namelist_element (stmtblock_t * block, const char * var_name,
 			     iocall[IOCALL_SET_NML_VAL_DIM], 5,
 			     dt_parm_addr,
 			     IARG (n_dim),
-			     GFC_TYPE_ARRAY_STRIDE (dt, n_dim),
-			     GFC_TYPE_ARRAY_LBOUND (dt, n_dim),
-			     GFC_TYPE_ARRAY_UBOUND (dt, n_dim));
+			     gfc_conv_array_stride (decl, n_dim),
+			     gfc_conv_array_lbound (decl, n_dim),
+			     gfc_conv_array_ubound (decl, n_dim));
       gfc_add_expr_to_block (block, tmp);
     }