re PR fortran/26074 (Module array cannot be automatic or assumed shape)

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

	PR fortran/26074
	PR fortran/25103
	* resolve.c (resolve_symbol): Extend the requirement that module
	arrays have constant bounds to those in the main program.  At the
	same time simplify the array bounds, to avoiding trapping parameter
	array references, and exclude automatic character length from main
	and modules. Rearrange resolve_symbol and resolve_derived to put as
	each flavor together, as much as is possible and move all specific
	code for flavors FL_VARIABLE, FL_PROCEDURE and FL_PARAMETER into new
	functions.
	(resolve_fl_var_and_proc, resolve_fl_variable, resolve_fl_procedure):
	New functions to do work of resolve_symbol.
	(resolve_index_expr): New function that is called from resolved_symbol
	and is extracted from resolve_charlen.
	(resolve_charlen): Call this new function.
	(resolve_fl_derived): Renamed resolve_derived to be consistent with
	the naming of the new functions for the other flavours.  Change the
	charlen checking so that the style is consistent with other similar
	checks. Add the generation of the gfc_dt_list, removed from resolve_
	symbol.

	PR fortran/20861
	* resolve.c (resolve_actual_arglist): Prevent internal procedures
	from being dummy arguments.

	PR fortran/20871
	* resolve.c (resolve_actual_arglist): Prevent pure but non-intrinsic
	procedures from being dummy arguments.

	PR fortran/25083
	* resolve.c (check_data_variable): Add test that data variable is in
	COMMON.

	PR fortran/25088
	* resolve.c (resolve_call): Add test that the subroutine does not
	have a type.


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

	PR fortran/26074
	PR fortran/25103
	* gfortran.dg/module_parameter_array_refs_1.f90: New test.
	* gfortran.dg/bad_automatic_objects_1.f90: New test.
	* gfortran.dg/automatic_module_variable.f90: Change error message.

	PR fortran/20861
	* gfortran.dg/internal_dummy_1.f90: New test.

	PR fortran/20871
	* gfortran.dg/elemental_non_intrinsic_dummy_1.f90: New test.


	PR fortran/25083
	* gfortran.dg/uncommon_block_data_1.f90: New test.
	* gfortran.dg/equiv_constraint_7.f90: Correct non-compliance of test
	with standard.

	PR fortran/25088
	* gfortran.dg/typed_subroutine_1.f90: New test.

From-SVN: r110926

11 files changed, 597 insertions, 306 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 8551a74..619dd27 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,42 @@
+2006-02-13  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/26074
+	PR fortran/25103
+	* resolve.c (resolve_symbol): Extend the requirement that module
+	arrays have constant bounds to those in the main program.  At the
+	same time simplify the array bounds, to avoiding trapping parameter
+	array references, and exclude automatic character length from main
+	and modules. Rearrange resolve_symbol and resolve_derived to put as
+	each flavor together, as much as is possible and move all specific
+	code for flavors FL_VARIABLE, FL_PROCEDURE and FL_PARAMETER into new
+	functions.
+	(resolve_fl_var_and_proc, resolve_fl_variable, resolve_fl_procedure):
+	New functions to do work of resolve_symbol.
+	(resolve_index_expr): New function that is called from resolved_symbol
+	and is extracted from resolve_charlen.
+	(resolve_charlen): Call this new function.
+	(resolve_fl_derived): Renamed resolve_derived to be consistent with
+	the naming of the new functions for the other flavours.  Change the
+	charlen checking so that the style is consistent with other similar
+	checks. Add the generation of the gfc_dt_list, removed from resolve_
+	symbol.
+
+	PR fortran/20861
+	* resolve.c (resolve_actual_arglist): Prevent internal procedures
+	from being dummy arguments.
+
+	PR fortran/20871
+	* resolve.c (resolve_actual_arglist): Prevent pure but non-intrinsic
+	procedures from being dummy arguments.
+
+	PR fortran/25083
+	* resolve.c (check_data_variable): Add test that data variable is in
+	COMMON.
+
+	PR fortran/25088
+	* resolve.c (resolve_call): Add test that the subroutine does not
+	have a type.
+
 2006-02-12  Erik Edelmann  <eedelman@gcc.gnu.org>
 
 	PR fortran/25806
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index f8234bf..84d5c7b 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -809,11 +809,25 @@ resolve_actual_arglist (gfc_actual_arglist * arg)
 	  || sym->attr.external)
 	{
 
-          if (sym->attr.proc == PROC_ST_FUNCTION)
-            {
-              gfc_error ("Statement function '%s' at %L is not allowed as an "
-                         "actual argument", sym->name, &e->where);
-            }
+	  if (sym->attr.proc == PROC_ST_FUNCTION)
+	    {
+	      gfc_error ("Statement function '%s' at %L is not allowed as an "
+			 "actual argument", sym->name, &e->where);
+	    }
+
+	  if (sym->attr.contained && !sym->attr.use_assoc
+	      && sym->ns->proc_name->attr.flavor != FL_MODULE)
+	    {
+	      gfc_error ("Internal procedure '%s' is not allowed as an "
+			 "actual argument at %L", sym->name, &e->where);
+	    }
+
+	  if (sym->attr.elemental && !sym->attr.intrinsic)
+	    {
+	      gfc_error ("ELEMENTAL non-INTRINSIC procedure '%s' is not "
+		         "allowed as an actual argument at %L", sym->name,
+			 &e->where);
+	    }
 
 	  /* If the symbol is the function that names the current (or
 	     parent) scope, then we really have a variable reference.  */
@@ -1579,6 +1593,15 @@ resolve_call (gfc_code * c)
 {
   try t;
 
+  if (c->symtree && c->symtree->n.sym
+	&& c->symtree->n.sym->ts.type != BT_UNKNOWN)
+    {
+      gfc_error ("'%s' at %L has a type, which is not consistent with "
+		 "the CALL at %L", c->symtree->n.sym->name,
+		 &c->symtree->n.sym->declared_at, &c->loc);
+      return FAILURE;
+    }
+
   /* If the procedure is not internal or module, it must be external and
      should be checked for usage.  */
   if (c->symtree && c->symtree->n.sym
@@ -4459,6 +4482,24 @@ resolve_values (gfc_symbol * sym)
 }
 
 
+/* Resolve an index expression.  */
+
+static try
+resolve_index_expr (gfc_expr * e)
+{
+
+  if (gfc_resolve_expr (e) == FAILURE)
+    return FAILURE;
+
+  if (gfc_simplify_expr (e, 0) == FAILURE)
+    return FAILURE;
+
+  if (gfc_specification_expr (e) == FAILURE)
+    return FAILURE;
+
+  return SUCCESS;
+}
+
 /* Resolve a charlen structure.  */
 
 static try
@@ -4469,15 +4510,303 @@ resolve_charlen (gfc_charlen *cl)
 
   cl->resolved = 1;
 
-  if (gfc_resolve_expr (cl->length) == FAILURE)
+  if (resolve_index_expr (cl->length) == FAILURE)
     return FAILURE;
 
-  if (gfc_simplify_expr (cl->length, 0) == FAILURE)
+  return SUCCESS;
+}
+
+
+/* Resolution of common features of flavors variable and procedure. */
+
+static try
+resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
+{
+  /* Constraints on deferred shape variable.  */
+  if (sym->as == NULL || sym->as->type != AS_DEFERRED)
+    {
+      if (sym->attr.allocatable)
+	{
+	  if (sym->attr.dimension)
+	    gfc_error ("Allocatable array '%s' at %L must have "
+		       "a deferred shape", sym->name, &sym->declared_at);
+	  else
+	    gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
+		       sym->name, &sym->declared_at);
+	    return FAILURE;
+	}
+
+      if (sym->attr.pointer && sym->attr.dimension)
+	{
+	  gfc_error ("Array pointer '%s' at %L must have a deferred shape",
+		     sym->name, &sym->declared_at);
+	  return FAILURE;
+	}
+
+    }
+  else
+    {
+      if (!mp_flag && !sym->attr.allocatable
+	     && !sym->attr.pointer && !sym->attr.dummy)
+	{
+	  gfc_error ("Array '%s' at %L cannot have a deferred shape",
+		     sym->name, &sym->declared_at);
+	  return FAILURE;
+	 }
+    }
+  return SUCCESS;
+}
+
+/* Resolve symbols with flavor variable.  */
+
+static try
+resolve_fl_variable (gfc_symbol *sym, int mp_flag)
+{
+  int flag;
+  int i;
+  gfc_expr *e;
+  gfc_expr *constructor_expr;
+
+  if (resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
     return FAILURE;
 
-  if (gfc_specification_expr (cl->length) == 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)
+    {
+      /* Make sure that character string variables with assumed length are
+	 dummy arguments.  */
+      e = sym->ts.cl->length;
+      if (e == NULL && !sym->attr.dummy && !sym->attr.result)
+	{
+	  gfc_error ("Entity with assumed character length at %L must be a "
+		     "dummy argument or a PARAMETER", &sym->declared_at);
+	  return FAILURE;
+	}
+
+      if (!gfc_is_constant_expr (e)
+	    && !(e->expr_type == EXPR_VARIABLE
+	    && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
+	    && sym->ns->proc_name
+	    && (sym->ns->proc_name->attr.flavor == FL_MODULE
+		  || sym->ns->proc_name->attr.is_main_program)
+	    && !sym->attr.use_assoc)
+	{
+	  gfc_error ("'%s' at %L must have constant character length "
+		     "in this context", sym->name, &sym->declared_at);
+	  return FAILURE;
+	}
+    }
+
+  /* Can the symbol have an initializer?  */
+  flag = 0;
+  if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
+	|| sym->attr.intrinsic || sym->attr.result)
+    flag = 1;
+  else if (sym->attr.dimension && !sym->attr.pointer)
+    {
+      /* Don't allow initialization of automatic arrays.  */
+      for (i = 0; i < sym->as->rank; i++)
+	{
+	  if (sym->as->lower[i] == NULL
+		|| sym->as->lower[i]->expr_type != EXPR_CONSTANT
+		|| sym->as->upper[i] == NULL
+		|| sym->as->upper[i]->expr_type != EXPR_CONSTANT)
+	    {
+	      flag = 1;
+	      break;
+	    }
+	}
+  }
+
+  /* Reject illegal initializers.  */
+  if (sym->value && flag)
+    {
+      if (sym->attr.allocatable)
+	gfc_error ("Allocatable '%s' at %L cannot have an initializer",
+		   sym->name, &sym->declared_at);
+      else if (sym->attr.external)
+	gfc_error ("External '%s' at %L cannot have an initializer",
+		   sym->name, &sym->declared_at);
+      else if (sym->attr.dummy)
+	gfc_error ("Dummy '%s' at %L cannot have an initializer",
+		   sym->name, &sym->declared_at);
+      else if (sym->attr.intrinsic)
+	gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
+		   sym->name, &sym->declared_at);
+      else if (sym->attr.result)
+	gfc_error ("Function result '%s' at %L cannot have an initializer",
+		   sym->name, &sym->declared_at);
+      else
+	gfc_error ("Automatic array '%s' at %L cannot have an initializer",
+		   sym->name, &sym->declared_at);
+      return FAILURE;
+    }
+
+  /* 4th constraint in section 11.3:  "If an object of a type for which
+     component-initialization is specified (R429) appears in the
+     specification-part of a module and does not have the ALLOCATABLE
+     or POINTER attribute, the object shall have the SAVE attribute."  */
+
+  constructor_expr = NULL;
+  if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
+	constructor_expr = gfc_default_initializer (&sym->ts);
+
+  if (sym->ns->proc_name
+	&& sym->ns->proc_name->attr.flavor == FL_MODULE
+	&& constructor_expr
+	&& !sym->ns->save_all && !sym->attr.save
+	&& !sym->attr.pointer && !sym->attr.allocatable)
+    {
+      gfc_error("Object '%s' at %L must have the SAVE attribute %s",
+ 	 	sym->name, &sym->declared_at,
+		"for default initialization of a component");
+      return FAILURE;
+    }
+
+  /* Assign default initializer.  */
+  if (sym->ts.type == BT_DERIVED && !(sym->value || flag)
+	&& !sym->attr.pointer)
+    sym->value = gfc_default_initializer (&sym->ts);
+
+  return SUCCESS;
+}
+
+
+/* Resolve a procedure.  */
+
+static try
+resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
+{
+  gfc_formal_arglist *arg;
+
+  if (sym->attr.function
+	&& resolve_fl_var_and_proc (sym, mp_flag) == FAILURE)
     return FAILURE;
 
+  if (sym->attr.proc == PROC_ST_FUNCTION)
+    {
+      if (sym->ts.type == BT_CHARACTER)
+        {
+          gfc_charlen *cl = sym->ts.cl;
+          if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
+            {
+              gfc_error ("Character-valued statement function '%s' at %L must "
+                         "have constant length", sym->name, &sym->declared_at);
+              return FAILURE;
+            }
+        }
+    }
+
+  /* Ensure that derived type formal arguments of a public procedure
+     are not of a private type.  */
+  if (gfc_check_access(sym->attr.access, sym->ns->default_access))
+    {
+      for (arg = sym->formal; arg; arg = arg->next)
+	{
+	  if (arg->sym
+		&& arg->sym->ts.type == BT_DERIVED
+		&& !arg->sym->ts.derived->attr.use_assoc
+		&& !gfc_check_access(arg->sym->ts.derived->attr.access,
+			arg->sym->ts.derived->ns->default_access))
+	    {
+	      gfc_error_now ("'%s' is of a PRIVATE type and cannot be "
+			     "a dummy argument of '%s', which is "
+			     "PUBLIC at %L", arg->sym->name, sym->name,
+			     &sym->declared_at);
+	      /* Stop this message from recurring.  */
+	      arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
+	      return FAILURE;
+	    }
+	}
+    }
+
+  /* An external symbol may not have an intializer because it is taken to be
+     a procedure.  */
+  if (sym->attr.external && sym->value)
+    {
+      gfc_error ("External object '%s' at %L may not have an initializer",
+		 sym->name, &sym->declared_at);
+      return FAILURE;
+    }
+
+  /* 5.1.1.5 of the Standard: A function name declared with an asterisk
+     char-len-param shall not be array-valued, pointer-valued, recursive
+     or pure.  ....snip... A character value of * may only be used in the
+     following ways: (i) Dummy arg of procedure - dummy associates with
+     actual length; (ii) To declare a named constant; or (iii) External
+     function - but length must be declared in calling scoping unit.  */
+  if (sym->attr.function
+	&& sym->ts.type == BT_CHARACTER
+	&& sym->ts.cl && sym->ts.cl->length == NULL)
+    {
+      if ((sym->as && sym->as->rank) || (sym->attr.pointer)
+	     || (sym->attr.recursive) || (sym->attr.pure))
+	{
+	  if (sym->as && sym->as->rank)
+	    gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
+		       "array-valued", sym->name, &sym->declared_at);
+
+	  if (sym->attr.pointer)
+	    gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
+		       "pointer-valued", sym->name, &sym->declared_at);
+
+	  if (sym->attr.pure)
+	    gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
+		       "pure", sym->name, &sym->declared_at);
+
+	  if (sym->attr.recursive)
+	    gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
+		       "recursive", sym->name, &sym->declared_at);
+
+	  return FAILURE;
+	}
+
+      /* Appendix B.2 of the standard.  Contained functions give an
+	 error anyway.  Fixed-form is likely to be F77/legacy.  */
+      if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
+	gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
+			"'%s' at %L is obsolescent in fortran 95",
+			sym->name, &sym->declared_at);
+    }
   return SUCCESS;
 }
 
@@ -4485,18 +4814,18 @@ resolve_charlen (gfc_charlen *cl)
 /* Resolve the components of a derived type.  */
 
 static try
-resolve_derived (gfc_symbol *sym)
+resolve_fl_derived (gfc_symbol *sym)
 {
   gfc_component *c;
+  gfc_dt_list * dt_list;
+  int i;
 
   for (c = sym->components; c != NULL; c = c->next)
     {
       if (c->ts.type == BT_CHARACTER)
 	{
-         if (resolve_charlen (c->ts.cl) == FAILURE)
-	   return FAILURE;
-	 
 	 if (c->ts.cl->length == NULL
+	     || (resolve_charlen (c->ts.cl) == FAILURE)
 	     || !gfc_is_constant_expr (c->ts.cl->length))
 	   {
 	     gfc_error ("Character length of component '%s' needs to "
@@ -4507,12 +4836,86 @@ resolve_derived (gfc_symbol *sym)
 	   }
 	}
 
-      /* TODO: Anything else that should be done here?  */
+      if (c->ts.type == BT_DERIVED
+	    && sym->component_access != ACCESS_PRIVATE
+	    && gfc_check_access(sym->attr.access, sym->ns->default_access)
+	    && !c->ts.derived->attr.use_assoc
+	    && !gfc_check_access(c->ts.derived->attr.access,
+				 c->ts.derived->ns->default_access))
+	{
+	  gfc_error ("The component '%s' is a PRIVATE type and cannot be "
+		     "a component of '%s', which is PUBLIC at %L",
+		      c->name, sym->name, &sym->declared_at);
+	  return FAILURE;
+	}
+
+      if (c->pointer || c->as == NULL)
+	continue;
+
+      for (i = 0; i < c->as->rank; i++)
+	{
+	  if (c->as->lower[i] == NULL
+		|| !gfc_is_constant_expr (c->as->lower[i])
+		|| (resolve_index_expr (c->as->lower[i]) == FAILURE)
+		|| c->as->upper[i] == NULL
+		|| (resolve_index_expr (c->as->upper[i]) == FAILURE)
+		|| !gfc_is_constant_expr (c->as->upper[i]))
+	    {
+	      gfc_error ("Component '%s' of '%s' at %L must have "
+			 "constant array bounds.",
+			 c->name, sym->name, &c->loc);
+	      return FAILURE;
+	    }
+	}
+    }
+    
+  /* Add derived type to the derived type list.  */
+  dt_list = gfc_get_dt_list ();
+  dt_list->next = sym->ns->derived_types;
+  dt_list->derived = sym;
+  sym->ns->derived_types = dt_list;
+
+  return SUCCESS;
+}
+
+
+static try
+resolve_fl_parameter (gfc_symbol *sym)
+{
+  /* A parameter array's shape needs to be constant.  */
+  if (sym->as != NULL && !gfc_is_compile_time_shape (sym->as))
+    {
+      gfc_error ("Parameter array '%s' at %L cannot be automatic "
+		 "or assumed shape", sym->name, &sym->declared_at);
+      return FAILURE;
     }
 
+  /* Make sure a parameter that has been implicitly typed still
+     matches the implicit type, since PARAMETER statements can precede
+     IMPLICIT statements.  */
+  if (sym->attr.implicit_type
+	&& !gfc_compare_types (&sym->ts,
+			       gfc_get_default_type (sym, sym->ns)))
+    {
+      gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
+		 "later IMPLICIT type", sym->name, &sym->declared_at);
+      return FAILURE;
+    }
+
+  /* Make sure the types of derived parameters are consistent.  This
+     type checking is deferred until resolution because the type may
+     refer to a derived type from the host.  */
+  if (sym->ts.type == BT_DERIVED
+	&& !gfc_compare_types (&sym->ts, &sym->value->ts))
+    {
+      gfc_error ("Incompatible derived type in PARAMETER at %L",
+		 &sym->value->where);
+      return FAILURE;
+    }
   return SUCCESS;
 }
 
+
 /* 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.  */
@@ -4523,14 +4926,11 @@ resolve_symbol (gfc_symbol * sym)
   /* Zero if we are checking a formal namespace.  */
   static int formal_ns_flag = 1;
   int formal_ns_save, check_constant, mp_flag;
-  int i, flag;
   gfc_namelist *nl;
   gfc_symtree *symtree;
   gfc_symtree *this_symtree;
   gfc_namespace *ns;
   gfc_component *c;
-  gfc_formal_arglist *arg;
-  gfc_expr *constructor_expr;
 
   if (sym->attr.flavor == FL_UNKNOWN)
     {
@@ -4566,7 +4966,7 @@ resolve_symbol (gfc_symbol * sym)
 	}
     }
 
-  if (sym->attr.flavor == FL_DERIVED && resolve_derived (sym) == FAILURE)
+  if (sym->attr.flavor == FL_DERIVED && resolve_fl_derived (sym) == FAILURE)
     return;
 
   /* Symbols that are module procedures with results (functions) have
@@ -4618,69 +5018,11 @@ resolve_symbol (gfc_symbol * sym)
       return;
     }
 
-  /* A parameter array's shape needs to be constant.  */
-
-  if (sym->attr.flavor == FL_PARAMETER && sym->as != NULL 
-      && !gfc_is_compile_time_shape (sym->as))
-    {
-      gfc_error ("Parameter array '%s' at %L cannot be automatic "
-		 "or assumed shape", sym->name, &sym->declared_at);
-	  return;
-    }
-
-  /* A module array's shape needs to be constant.  */
-
-  if (sym->ns->proc_name
-      && sym->attr.flavor == FL_VARIABLE
-      && sym->ns->proc_name->attr.flavor == FL_MODULE
-      && !sym->attr.use_assoc
-      && !sym->attr.allocatable
-      && !sym->attr.pointer
-      && sym->as != NULL
-      && !gfc_is_compile_time_shape (sym->as))
-    {
-      gfc_error ("Module array '%s' at %L cannot be automatic "
-         "or assumed shape", sym->name, &sym->declared_at);
-      return;
-    }
-
-  /* Make sure that character string variables with assumed length are
-     dummy arguments.  */
-
-  if (sym->attr.flavor == FL_VARIABLE && !sym->attr.result
-      && sym->ts.type == BT_CHARACTER
-      && sym->ts.cl->length == NULL && sym->attr.dummy == 0)
-    {
-      gfc_error ("Entity with assumed character length at %L must be a "
-		 "dummy argument or a PARAMETER", &sym->declared_at);
-      return;
-    }
-
-  /* Make sure a parameter that has been implicitly typed still
-     matches the implicit type, since PARAMETER statements can precede
-     IMPLICIT statements.  */
-
-  if (sym->attr.flavor == FL_PARAMETER
-      && sym->attr.implicit_type
-      && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym, sym->ns)))
-    gfc_error ("Implicitly typed PARAMETER '%s' at %L doesn't match a "
-	       "later IMPLICIT type", sym->name, &sym->declared_at);
-
-  /* Make sure the types of derived parameters are consistent.  This
-     type checking is deferred until resolution because the type may
-     refer to a derived type from the host.  */
-
-  if (sym->attr.flavor == FL_PARAMETER
-      && sym->ts.type == BT_DERIVED
-      && !gfc_compare_types (&sym->ts, &sym->value->ts))
-    gfc_error ("Incompatible derived type in PARAMETER at %L",
-	       &sym->value->where);
-
   /* Make sure symbols with known intent or optional are really dummy
      variable.  Because of ENTRY statement, this has to be deferred
      until resolution time.  */
 
-  if (! sym->attr.dummy
+  if (!sym->attr.dummy
       && (sym->attr.optional
 	  || sym->attr.intent != INTENT_UNKNOWN))
     {
@@ -4688,20 +5030,6 @@ resolve_symbol (gfc_symbol * sym)
       return;
     }
 
-  if (sym->attr.proc == PROC_ST_FUNCTION)
-    {
-      if (sym->ts.type == BT_CHARACTER)
-        {
-          gfc_charlen *cl = sym->ts.cl;
-          if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT)
-            {
-              gfc_error ("Character-valued statement function '%s' at %L must "
-                         "have constant length", sym->name, &sym->declared_at);
-              return;
-            }
-        }
-    }
-
   /* If a derived type symbol has reached this point, without its
      type being declared, we have an error.  Notice that most
      conditions that produce undefined derived types have already
@@ -4720,28 +5048,6 @@ resolve_symbol (gfc_symbol * sym)
       return;
     }
 
-  /* If a component of a derived type is of a type declared to be private,
-     either the derived type definition must contain the PRIVATE statement,
-     or the derived type must be private.  (4.4.1 just after R427) */
-  if (sym->attr.flavor == FL_DERIVED
-	&& sym->component_access != ACCESS_PRIVATE
-	&& gfc_check_access(sym->attr.access, sym->ns->default_access))
-    {
-      for (c = sym->components; c; c = c->next)
-	{
-	  if (c->ts.type == BT_DERIVED
-		&& !c->ts.derived->attr.use_assoc
-		&& !gfc_check_access(c->ts.derived->attr.access,
-				     c->ts.derived->ns->default_access))
-	    {
-	      gfc_error ("The component '%s' is a PRIVATE type and cannot be "
-			 "a component of '%s', which is PUBLIC at %L",
-			 c->name, sym->name, &sym->declared_at);
-	      return;
-	    }
-	}
-    }
-
   /* An assumed-size array with INTENT(OUT) shall not be of a type for which
      default initialization is defined (5.1.2.4.4).  */
   if (sym->ts.type == BT_DERIVED
@@ -4762,141 +5068,16 @@ resolve_symbol (gfc_symbol * sym)
 	}
     }
 
-
-  /* Ensure that derived type formal arguments of a public procedure
-     are not of a private type.  */
-  if (sym->attr.flavor == FL_PROCEDURE
-	&& gfc_check_access(sym->attr.access, sym->ns->default_access))
-    {
-      for (arg = sym->formal; arg; arg = arg->next)
-	{
-	  if (arg->sym
-		&& arg->sym->ts.type == BT_DERIVED
-		&& !arg->sym->ts.derived->attr.use_assoc
-		&& !gfc_check_access(arg->sym->ts.derived->attr.access,
-				     arg->sym->ts.derived->ns->default_access))
-	    {
-	      gfc_error_now ("'%s' is a PRIVATE type and cannot be "
-			     "a dummy argument of '%s', which is PUBLIC at %L",
-			     arg->sym->name, sym->name, &sym->declared_at);
-	      /* Stop this message from recurring.  */
-	      arg->sym->ts.derived->attr.access = ACCESS_PUBLIC;
-	      return;
-	    }
-	}
-    }
-
-  /* Constraints on deferred shape variable.  */
-  if (sym->attr.flavor == FL_VARIABLE
-      || (sym->attr.flavor == FL_PROCEDURE
-	  && sym->attr.function))
-    {
-      if (sym->as == NULL || sym->as->type != AS_DEFERRED)
-	{
-	  if (sym->attr.allocatable)
-	    {
-	      if (sym->attr.dimension)
-		gfc_error ("Allocatable array '%s' at %L must have "
-			   "a deferred shape", sym->name, &sym->declared_at);
-	      else
-		gfc_error ("Scalar object '%s' at %L may not be ALLOCATABLE",
-			   sym->name, &sym->declared_at);
-	      return;
-	    }
-
-	  if (sym->attr.pointer && sym->attr.dimension)
-	    {
-	      gfc_error ("Array pointer '%s' at %L must have a deferred shape",
-			 sym->name, &sym->declared_at);
-	      return;
-	    }
-
-	}
-      else
-	{
-	  if (!mp_flag && !sym->attr.allocatable
-	      && !sym->attr.pointer && !sym->attr.dummy)
-	    {
-	      gfc_error ("Array '%s' at %L cannot have a deferred shape",
-			 sym->name, &sym->declared_at);
-	      return;
-	    }
-	}
-    }
-
   switch (sym->attr.flavor)
     {
     case FL_VARIABLE:
-      /* Can the symbol have an initializer?  */
-      flag = 0;
-      if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy
-	  || sym->attr.intrinsic || sym->attr.result)
-	flag = 1;
-      else if (sym->attr.dimension && !sym->attr.pointer)
-	{
-	  /* Don't allow initialization of automatic arrays.  */
-	  for (i = 0; i < sym->as->rank; i++)
-	    {
-	      if (sym->as->lower[i] == NULL
-		  || sym->as->lower[i]->expr_type != EXPR_CONSTANT
-		  || sym->as->upper[i] == NULL
-		  || sym->as->upper[i]->expr_type != EXPR_CONSTANT)
-		{
-		  flag = 1;
-		  break;
-		}
-	    }
-	}
-
-      /* Reject illegal initializers.  */
-      if (sym->value && flag)
-	{
-	  if (sym->attr.allocatable)
-	    gfc_error ("Allocatable '%s' at %L cannot have an initializer",
-		       sym->name, &sym->declared_at);
-	  else if (sym->attr.external)
-	    gfc_error ("External '%s' at %L cannot have an initializer",
-		       sym->name, &sym->declared_at);
-	  else if (sym->attr.dummy)
-	    gfc_error ("Dummy '%s' at %L cannot have an initializer",
-		       sym->name, &sym->declared_at);
-	  else if (sym->attr.intrinsic)
-	    gfc_error ("Intrinsic '%s' at %L cannot have an initializer",
-		       sym->name, &sym->declared_at);
-	  else if (sym->attr.result)
-	    gfc_error ("Function result '%s' at %L cannot have an initializer",
-		       sym->name, &sym->declared_at);
-	  else
-	    gfc_error ("Automatic array '%s' at %L cannot have an initializer",
-		       sym->name, &sym->declared_at);
-	  return;
-	}
-
-     /* 4th constraint in section 11.3:  "If an object of a type for which
-	component-initialization is specified (R429) appears in the
-	specification-part of a module and does not have the ALLOCATABLE
-	or POINTER attribute, the object shall have the SAVE attribute."  */
-
-      constructor_expr = NULL;
-      if (sym->ts.type == BT_DERIVED && !(sym->value || flag))
-        constructor_expr = gfc_default_initializer (&sym->ts);
-
-      if (sym->ns->proc_name
-	  && sym->ns->proc_name->attr.flavor == FL_MODULE
-	  && constructor_expr
-	  && !sym->ns->save_all && !sym->attr.save
-	  && !sym->attr.pointer && !sym->attr.allocatable)
-	{
-	  gfc_error("Object '%s' at %L must have the SAVE attribute %s",
- 	 	     sym->name, &sym->declared_at,
-		     "for default initialization of a component");
-	  return;
-	}
+      if (resolve_fl_variable (sym, mp_flag) == FAILURE)
+	return;
+      break;
 
-      /* Assign default initializer.  */
-      if (sym->ts.type == BT_DERIVED && !(sym->value || flag)
-          && !sym->attr.pointer)
-	sym->value = gfc_default_initializer (&sym->ts);
+    case FL_PROCEDURE:
+      if (resolve_fl_procedure (sym, mp_flag) == FAILURE)
+	return;
       break;
 
     case FL_NAMELIST:
@@ -4916,69 +5097,13 @@ resolve_symbol (gfc_symbol * sym)
 			   &sym->declared_at);
 	    }
 	}
-      break;
-
-    case FL_PROCEDURE:
-      /* An external symbol may not have an intializer because it is taken to be
-	 a procedure.  */
-      if (sym->attr.external && sym->value)
-	{
-	  gfc_error ("External object '%s' at %L may not have an initializer",
-		     sym->name, &sym->declared_at);
-	  return;
-	}
-
-      /* 5.1.1.5 of the Standard: A function name declared with an asterisk
-	 char-len-param shall not be array-valued, pointer-valued, recursive
-	 or pure.  ....snip... A character value of * may only be used in the
-	 following ways: (i) Dummy arg of procedure - dummy associates with
-	 actual length; (ii) To declare a named constant; or (iii) External
-	 function - but length must be declared in calling scoping unit.  */
-      if (sym->attr.function
-	    && sym->ts.type == BT_CHARACTER
-	    && sym->ts.cl && sym->ts.cl->length == NULL)
-	{
-	  if ((sym->as && sym->as->rank) || (sym->attr.pointer)
-		 || (sym->attr.recursive) || (sym->attr.pure))
-	    {
-	      if (sym->as && sym->as->rank)
-		gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
-			   "array-valued", sym->name, &sym->declared_at);
-
-	      if (sym->attr.pointer)
-		gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
-			   "pointer-valued", sym->name, &sym->declared_at);
-
-	      if (sym->attr.pure)
-		gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
-			   "pure", sym->name, &sym->declared_at);
-
-	      if (sym->attr.recursive)
-		gfc_error ("CHARACTER(*) function '%s' at %L cannot be "
-			   "recursive", sym->name, &sym->declared_at);
-
-	      return;
-	    }
-
-	  /* Appendix B.2 of the standard.  Contained functions give an
-	     error anyway.  Fixed-form is likely to be F77/legacy.  */
-	  if (!sym->attr.contained && gfc_current_form != FORM_FIXED)
-	    gfc_notify_std (GFC_STD_F95_OBS, "CHARACTER(*) function "
-			    "'%s' at %L is obsolescent in fortran 95",
-			    sym->name, &sym->declared_at);
-	}
 
       break;
 
-    case FL_DERIVED:
-      /* Add derived type to the derived type list.  */
-      {
-	gfc_dt_list * dt_list;
-	dt_list = gfc_get_dt_list ();
-	dt_list->next = sym->ns->derived_types;
-	dt_list->derived = sym;
-	sym->ns->derived_types = dt_list;
-      }
+    case FL_PARAMETER:
+      if (resolve_fl_parameter (sym) == FAILURE)
+	return;
+
       break;
 
     default:
@@ -5063,6 +5188,13 @@ check_data_variable (gfc_data_variable * var, locus * where)
   if (e->expr_type != EXPR_VARIABLE)
     gfc_internal_error ("check_data_variable(): Bad expression");
 
+  if (e->symtree->n.sym->ns->is_block_data
+	&& !e->symtree->n.sym->attr.in_common)
+    {
+      gfc_error ("BLOCK DATA element '%s' at %L must be in COMMON",
+	         e->symtree->n.sym->name, &e->symtree->n.sym->declared_at);
+    }
+
   if (e->rank == 0)
     {
       mpz_init_set_ui (size, 1);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index c0b1911..1139140 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,26 @@
+2006-02-13  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/26074
+	PR fortran/25103
+	* gfortran.dg/module_parameter_array_refs_1.f90: New test.
+	* gfortran.dg/bad_automatic_objects_1.f90: New test.
+	* gfortran.dg/automatic_module_variable.f90: Change error message.
+
+	PR fortran/20861
+	* gfortran.dg/internal_dummy_1.f90: New test.
+
+	PR fortran/20871
+	* gfortran.dg/elemental_non_intrinsic_dummy_1.f90: New test.
+
+
+	PR fortran/25083
+	* gfortran.dg/uncommon_block_data_1.f90: New test.
+	* gfortran.dg/equiv_constraint_7.f90: Correct non-compliance of test
+	with standard.
+
+	PR fortran/25088
+	* gfortran.dg/typed_subroutine_1.f90: New test.
+
 2006-02-13  Geoffrey Keating  <geoffk@apple.com>
 
 	* objc.dg/dwarf-1.m: New.
diff --git a/gcc/testsuite/gfortran.dg/automatic_module_variable.f90 b/gcc/testsuite/gfortran.dg/automatic_module_variable.f90
index 0cf43f7..201dcf4 100644
--- a/gcc/testsuite/gfortran.dg/automatic_module_variable.f90
+++ b/gcc/testsuite/gfortran.dg/automatic_module_variable.f90
@@ -4,7 +4,7 @@
 module sd
   integer, parameter :: n = 20
   integer :: i(n)
-  integer :: j(m) ! { dg-error "cannot be automatic or assumed shape" }
+  integer :: j(m) ! { dg-error "must have constant shape" }
   integer, pointer :: p(:)
   integer, allocatable :: q(:)
 contains
diff --git a/gcc/testsuite/gfortran.dg/bad_automatic_objects_1.f90 b/gcc/testsuite/gfortran.dg/bad_automatic_objects_1.f90
new file mode 100644
index 0000000..2734418
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bad_automatic_objects_1.f90
@@ -0,0 +1,20 @@
+! { dg-do compile }
+! Tests the fix for 25103, in which the presence of automatic objects
+! in the main program and the specification part of a module was not
+! detected.
+!
+! Contributed by Joost VandeVondele  <jv244@cam.ac.uk>
+!
+module foo
+  integer    ::  i
+end module foo
+module bar
+  use foo
+  integer, dimension (i) :: j ! { dg-error "must have constant shape" }
+  character (len = i) :: c1   ! { dg-error "must have constant character length" }
+end module bar
+program foobar
+  use foo
+  integer, dimension (i) :: k ! { dg-error "must have constant shape" }
+  character (len = i) :: c2   ! { dg-error "must have constant character length" }
+end program foobar
diff --git a/gcc/testsuite/gfortran.dg/elemental_non_intrinsic_dummy_1.f90 b/gcc/testsuite/gfortran.dg/elemental_non_intrinsic_dummy_1.f90
new file mode 100644
index 0000000..c14a5d8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/elemental_non_intrinsic_dummy_1.f90
@@ -0,0 +1,21 @@
+! { dg-do compile }
+! Tests the fix for 20871, in which elemental non-intrinsic procedures were
+! permitted to be dummy arguments.
+!
+! Contributed by Joost VandeVondele  <jv244@cam.ac.uk>
+!
+MODULE TT
+CONTAINS
+   ELEMENTAL INTEGER FUNCTION two(N)
+     INTEGER, INTENT(IN) :: N
+     two=2**N
+   END FUNCTION
+END MODULE
+USE TT
+ INTEGER, EXTERNAL  :: SUB
+ write(6,*) SUB(two)    ! { dg-error "not allowed as an actual argument " }
+END
+INTEGER FUNCTION SUB(XX)
+  INTEGER :: XX
+  SUB=XX()
+END
diff --git a/gcc/testsuite/gfortran.dg/equiv_constraint_7.f90 b/gcc/testsuite/gfortran.dg/equiv_constraint_7.f90
index ec4579f..207b7d3 100644
--- a/gcc/testsuite/gfortran.dg/equiv_constraint_7.f90
+++ b/gcc/testsuite/gfortran.dg/equiv_constraint_7.f90
@@ -2,8 +2,10 @@
 ! { dg-options "-O0" }
 ! PR20890 - Equivalence cannot contain more than one initialized variables.
 ! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
- BLOCK DATA
+! Started out being in BLOCK DATA; however, blockdata variables must be in
+! COMMON and therefore cannot have F95 style initializers....
+ MODULE DATA
   INTEGER :: I=1,J=2
   EQUIVALENCE(I,J)  ! { dg-error "cannot both be in the EQUIVALENCE" }
- END BLOCK DATA
+ END MODULE DATA
  END
diff --git a/gcc/testsuite/gfortran.dg/internal_dummy_1.f90 b/gcc/testsuite/gfortran.dg/internal_dummy_1.f90
new file mode 100644
index 0000000..cae187e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/internal_dummy_1.f90
@@ -0,0 +1,19 @@
+! { dg-do compile }
+! Tests the fix for 20861, in which internal procedures were permitted to
+! be dummy arguments.
+!
+! Contributed by Joost VandeVondele  <jv244@cam.ac.uk>
+!
+CALL DD(TT) ! { dg-error "is not allowed as an actual argument" }
+CONTAINS
+SUBROUTINE DD(F)
+  INTERFACE
+   SUBROUTINE F(X)
+    REAL :: X
+   END SUBROUTINE F
+  END INTERFACE
+END SUBROUTINE DD
+SUBROUTINE TT(X)
+  REAL :: X
+END SUBROUTINE
+END
diff --git a/gcc/testsuite/gfortran.dg/module_parameter_array_refs_1.f90 b/gcc/testsuite/gfortran.dg/module_parameter_array_refs_1.f90
new file mode 100644
index 0000000..a78b525
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/module_parameter_array_refs_1.f90
@@ -0,0 +1,13 @@
+! { dg-do compile }
+! Tests the fix for 26074, in which the array reference below would
+! be determined not to be constant within modules.
+!
+! Contributed by Jonathan Dursi  <ljdursi@cita.utoronto.ca>
+!
+module foo
+
+   integer, parameter :: len = 5
+   integer :: arr(max(len,1))
+
+end
+
diff --git a/gcc/testsuite/gfortran.dg/typed_subroutine_1.f90 b/gcc/testsuite/gfortran.dg/typed_subroutine_1.f90
new file mode 100644
index 0000000..38619e7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/typed_subroutine_1.f90
@@ -0,0 +1,11 @@
+! { dg-do compile }
+! Tests the fix for 25088, in which the compiler failed to detect that
+! a called object had a type.
+!
+! Contributed by Joost VandeVondele  <jv244@cam.ac.uk>
+!
+ INTEGER :: S ! { dg-error "has a type, which is not consistent with the CALL " }
+ CALL S()     ! { dg-error "has a type, which is not consistent with the CALL " }
+ END
+ SUBROUTINE S
+ END SUBROUTINE
diff --git a/gcc/testsuite/gfortran.dg/uncommon_block_data_1.f90 b/gcc/testsuite/gfortran.dg/uncommon_block_data_1.f90
new file mode 100644
index 0000000..54547e8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/uncommon_block_data_1.f90
@@ -0,0 +1,11 @@
+! { dg-do compile }
+! Tests the fix for 25083, in which the compiler failed to detect that
+! data variables in BLOCK DATA were not in COMMON.
+!
+! Contributed by Joost VandeVondele  <jv244@cam.ac.uk>
+!
+ BLOCK DATA D
+  INTEGER I ! { dg-error "must be in COMMON" }
+  DATA I /1/
+ END BLOCK DATA
+END