re PR fortran/37274 ([Regression on 4.3?] error: type name is ambiguous.)

2008-09-18  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/37274
	PR fortran/36374
	* module.c (check_for_ambiguous): New function to test loaded
	symbol for ambiguity with fixup symbol.
	(read_module): Call check_for_ambiguous.
	(write_symtree): Do not write the symtree for symbols coming
	from an interface body.

	PR fortran/36374
	* resolve.c (count_specific_procs ): New function to count the
	number of specific procedures with the same name as the generic
	and emit appropriate errors for and actual argument reference.
	(resolve_assumed_size_actual): Add new argument no_formal_args.
	Correct logic around passing generic procedures as arguments.
	Call count_specific_procs from two locations.
	(resolve_function): Evaluate and pass no_formal_args.
	(resolve call): The same and clean up a bit by using csym more
	widely.

	PR fortran/36454
	* symbol.c (gfc_add_access): Access can be updated if use
	associated and not private.

2008-09-18  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/37274
	* gfortran.dg/used_types_22.f90: New test.
	* gfortran.dg/used_types_23.f90: New test.

	PR fortran/36374
	* gfortran.dg/generic_17.f90: New test.
	* gfortran.dg/ambiguous_specific_2.f90: New test.
	* gfortran.dg/generic_actual_arg.f90: Add test for case that is
	not ambiguous.

	PR fortran/36454
	* gfortran.dg/access_spec_3.f90: New test.

From-SVN: r140434

1 files changed, 65 insertions, 39 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 69245f2..a11b90d 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1040,6 +1040,38 @@ resolve_assumed_size_actual (gfc_expr *e)
 }
 
 
+/* Check a generic procedure, passed as an actual argument, to see if
+   there is a matching specific name.  If none, it is an error, and if
+   more than one, the reference is ambiguous.  */
+static int
+count_specific_procs (gfc_expr *e)
+{
+  int n;
+  gfc_interface *p;
+  gfc_symbol *sym;
+	
+  n = 0;
+  sym = e->symtree->n.sym;
+
+  for (p = sym->generic; p; p = p->next)
+    if (strcmp (sym->name, p->sym->name) == 0)
+      {
+	e->symtree = gfc_find_symtree (p->sym->ns->sym_root,
+				       sym->name);
+	n++;
+      }
+
+  if (n > 1)
+    gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
+	       &e->where);
+
+  if (n == 0)
+    gfc_error ("GENERIC procedure '%s' is not allowed as an actual "
+	       "argument at %L", sym->name, &e->where);
+
+  return n;
+}
+
 /* Resolve an actual argument list.  Most of the time, this is just
    resolving the expressions in the list.
    The exception is that we sometimes have to decide whether arguments
@@ -1047,13 +1079,14 @@ resolve_assumed_size_actual (gfc_expr *e)
    references.  */
 
 static gfc_try
-resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype)
+resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
+			bool no_formal_args)
 {
   gfc_symbol *sym;
   gfc_symtree *parent_st;
   gfc_expr *e;
   int save_need_full_assumed_size;
-
+	
   for (; arg; arg = arg->next)
     {
       e = arg->expr;
@@ -1072,12 +1105,11 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype)
 	  continue;
 	}
 
-      if (e->expr_type == EXPR_VARIABLE && e->symtree->ambiguous)
-	{
-	  gfc_error ("'%s' at %L is ambiguous", e->symtree->n.sym->name,
-		     &e->where);
-	  return FAILURE;
-	}
+      if (e->expr_type == FL_VARIABLE
+	    && e->symtree->n.sym->attr.generic
+	    && no_formal_args
+	    && count_specific_procs (e) != 1)
+	return FAILURE;
 
       if (e->ts.type != BT_PROCEDURE)
 	{
@@ -1138,23 +1170,11 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype)
 
 	  /* Check if a generic interface has a specific procedure
 	    with the same name before emitting an error.  */
-	  if (sym->attr.generic)
-	    {
-	      gfc_interface *p;
-	      for (p = sym->generic; p; p = p->next)
-		if (strcmp (sym->name, p->sym->name) == 0)
-		  {
-		    e->symtree = gfc_find_symtree
-					   (p->sym->ns->sym_root, sym->name);
-		    sym = p->sym;
-		    break;
-		  }
-
-	      if (p == NULL || e->symtree == NULL)
-		gfc_error ("GENERIC procedure '%s' is not "
-			   "allowed as an actual argument at %L", sym->name,
-			   &e->where);
-	    }
+	  if (sym->attr.generic && count_specific_procs (e) != 1)
+	    return FAILURE;
+	  
+	  /* Just in case a specific was found for the expression.  */
+	  sym = e->symtree->n.sym;
 
 	  /* If the symbol is the function that names the current (or
 	     parent) scope, then we really have a variable reference.  */
@@ -2199,6 +2219,7 @@ resolve_function (gfc_expr *expr)
   gfc_try t;
   int temp;
   procedure_type p = PROC_INTRINSIC;
+  bool no_formal_args;
 
   sym = NULL;
   if (expr->symtree)
@@ -2238,7 +2259,9 @@ resolve_function (gfc_expr *expr)
   if (expr->symtree && expr->symtree->n.sym)
     p = expr->symtree->n.sym->attr.proc;
 
-  if (resolve_actual_arglist (expr->value.function.actual, p) == FAILURE)
+  no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
+  if (resolve_actual_arglist (expr->value.function.actual,
+			      p, no_formal_args) == FAILURE)
       return FAILURE;
 
   /* Need to setup the call to the correct c_associated, depending on
@@ -2817,26 +2840,27 @@ resolve_call (gfc_code *c)
 {
   gfc_try t;
   procedure_type ptype = PROC_INTRINSIC;
+  gfc_symbol *csym;
+  bool no_formal_args;
+
+  csym = c->symtree ? c->symtree->n.sym : NULL;
 
-  if (c->symtree && c->symtree->n.sym
-      && c->symtree->n.sym->ts.type != BT_UNKNOWN)
+  if (csym && csym->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);
+		 "the CALL at %L", csym->name, &csym->declared_at, &c->loc);
       return FAILURE;
     }
 
   /* If external, check for usage.  */
-  if (c->symtree && is_external_proc (c->symtree->n.sym))
-    resolve_global_procedure (c->symtree->n.sym, &c->loc, 1);
+  if (csym && is_external_proc (csym))
+    resolve_global_procedure (csym, &c->loc, 1);
 
   /* Subroutines without the RECURSIVE attribution are not allowed to
    * call themselves.  */
-  if (c->symtree && c->symtree->n.sym && !c->symtree->n.sym->attr.recursive)
+  if (csym && !csym->attr.recursive)
     {
-      gfc_symbol *csym, *proc;
-      csym = c->symtree->n.sym;
+      gfc_symbol *proc;
       proc = gfc_current_ns->proc_name;
       if (csym == proc)
       {
@@ -2859,10 +2883,12 @@ resolve_call (gfc_code *c)
      of procedure, once the procedure itself is resolved.  */
   need_full_assumed_size++;
 
-  if (c->symtree && c->symtree->n.sym)
-    ptype = c->symtree->n.sym->attr.proc;
+  if (csym)
+    ptype = csym->attr.proc;
 
-  if (resolve_actual_arglist (c->ext.actual, ptype) == FAILURE)
+  no_formal_args = csym && is_external_proc (csym) && csym->formal == NULL;
+  if (resolve_actual_arglist (c->ext.actual, ptype,
+			      no_formal_args) == FAILURE)
     return FAILURE;
 
   /* Resume assumed_size checking.  */
@@ -2870,7 +2896,7 @@ resolve_call (gfc_code *c)
 
   t = SUCCESS;
   if (c->resolved_sym == NULL)
-    switch (procedure_kind (c->symtree->n.sym))
+    switch (procedure_kind (csym))
       {
       case PTYPE_GENERIC:
 	t = resolve_generic_s (c);