gfortran.h (enum gfc_statement): New entry `ST_GENERIC'.

2008-08-31  Daniel Kraft  <d@domob.eu>

	* gfortran.h (enum gfc_statement): New entry `ST_GENERIC'.
	(struct gfc_tbp_generic): New type.
	(struct gfc_typebound_proc): Removed `target' and added union with
	`specific' and `generic' members; new members `overridden',
	`subroutine', `function' and `is_generic'.
	(struct gfc_expr): New members `derived' and `name' in compcall union
	member and changed type of `tbp' to gfc_typebound_proc.
	(gfc_compare_interfaces), (gfc_compare_actual_formal): Made public.
	* match.h (gfc_typebound_default_access): New global.
	(gfc_match_generic): New method.
	* decl.c (gfc_match_generic): New method.
	(match_binding_attributes): New argument `generic' and handle it.
	(match_procedure_in_type): Mark matched binding as non-generic.
	* interface.c (gfc_compare_interfaces): Made public.
	(gfc_compare_actual_formal): Ditto.
	(check_interface_1), (compare_parameter): Use new public names.
	(gfc_procedure_use), (gfc_search_interface): Ditto.
	* match.c (match_typebound_call): Set base-symbol referenced.
	* module.c (binding_generic): New global array.
	(current_f2k_derived): New global.
	(mio_typebound_proc): Handle IO of GENERIC bindings.
	(mio_f2k_derived): Record current f2k-namespace in current_f2k_derived.
	* parse.c (decode_statement): Handle GENERIC statement.
	(gfc_ascii_statement): Ditto.
	(typebound_default_access), (set_typebound_default_access): Removed.
	(gfc_typebound_default_access): New global.
	(parse_derived_contains): New default-access implementation and handle
	GENERIC statements encountered.
	* primary.c (gfc_match_varspec): Adapted to new gfc_typebound_proc
	structure and removed check for SUBROUTINE/FUNCTION from here.
	* resolve.c (extract_compcall_passed_object): New method.
	(update_compcall_arglist): Use it.
	(resolve_typebound_static): Adapted to new gfc_typebound_proc structure.
	(resolve_typebound_generic_call): New method.
	(resolve_typebound_call): Check target is a SUBROUTINE and handle calls
	to GENERIC bindings.
	(resolve_compcall): Ditto (check for target being FUNCTION).
	(check_typebound_override): Handle GENERIC bindings.
	(check_generic_tbp_ambiguity), (resolve_typebound_generic): New methods.
	(resolve_typebound_procedure): Handle GENERIC bindings and set new
	attributes subroutine, function and overridden in gfc_typebound_proc.
	(resolve_fl_derived): Ensure extended type is resolved before the
	extending one is.
	* st.c (gfc_free_statement): Fix bug with free'ing EXEC_COMPCALL's.
	* symbol.c (gfc_find_typebound_proc): Adapt for GENERIC changes.

2008-08-31  Daniel Kraft  <d@domob.eu>

	* gfortran.dg/typebound_generic_1.f03: New test.
	* gfortran.dg/typebound_generic_2.f03: New test.
	* gfortran.dg/typebound_generic_3.f03: New test.

From-SVN: r139822

1 files changed, 313 insertions, 14 deletions

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index c6f59ad..440461c 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -4306,16 +4306,14 @@ update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos)
 }
 
 
-/* Update the arglist of an EXPR_COMPCALL expression to include the
-   passed-object.  */
+/* Extract the passed-object from an EXPR_COMPCALL (a copy of it).  */
 
-static gfc_try
-update_compcall_arglist (gfc_expr* e)
+static gfc_expr*
+extract_compcall_passed_object (gfc_expr* e)
 {
   gfc_expr* po;
-  gfc_typebound_proc* tbp;
 
-  tbp = e->value.compcall.tbp->typebound;
+  gcc_assert (e->expr_type == EXPR_COMPCALL);
 
   po = gfc_get_expr ();
   po->expr_type = EXPR_VARIABLE;
@@ -4323,7 +4321,27 @@ update_compcall_arglist (gfc_expr* e)
   po->ref = gfc_copy_ref (e->ref);
 
   if (gfc_resolve_expr (po) == FAILURE)
+    return NULL;
+
+  return po;
+}
+
+
+/* Update the arglist of an EXPR_COMPCALL expression to include the
+   passed-object.  */
+
+static gfc_try
+update_compcall_arglist (gfc_expr* e)
+{
+  gfc_expr* po;
+  gfc_typebound_proc* tbp;
+
+  tbp = e->value.compcall.tbp;
+
+  po = extract_compcall_passed_object (e);
+  if (!po)
     return FAILURE;
+
   if (po->rank > 0)
     {
       gfc_error ("Passed-object at %L must be scalar", &e->where);
@@ -4353,13 +4371,14 @@ resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
 			  gfc_actual_arglist** actual)
 {
   gcc_assert (e->expr_type == EXPR_COMPCALL);
+  gcc_assert (!e->value.compcall.tbp->is_generic);
 
   /* Update the actual arglist for PASS.  */
   if (update_compcall_arglist (e) == FAILURE)
     return FAILURE;
 
   *actual = e->value.compcall.actual;
-  *target = e->value.compcall.tbp->typebound->target;
+  *target = e->value.compcall.tbp->u.specific;
 
   gfc_free_ref_list (e->ref);
   e->ref = NULL;
@@ -4369,6 +4388,74 @@ resolve_typebound_static (gfc_expr* e, gfc_symtree** target,
 }
 
 
+/* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out
+   which of the specific bindings (if any) matches the arglist and transform
+   the expression into a call of that binding.  */
+
+static gfc_try
+resolve_typebound_generic_call (gfc_expr* e)
+{
+  gfc_typebound_proc* genproc;
+  const char* genname;
+
+  gcc_assert (e->expr_type == EXPR_COMPCALL);
+  genname = e->value.compcall.name;
+  genproc = e->value.compcall.tbp;
+
+  if (!genproc->is_generic)
+    return SUCCESS;
+
+  /* Try the bindings on this type and in the inheritance hierarchy.  */
+  for (; genproc; genproc = genproc->overridden)
+    {
+      gfc_tbp_generic* g;
+
+      gcc_assert (genproc->is_generic);
+      for (g = genproc->u.generic; g; g = g->next)
+	{
+	  gfc_symbol* target;
+	  gfc_actual_arglist* args;
+	  bool matches;
+
+	  gcc_assert (g->specific);
+	  target = g->specific->u.specific->n.sym;
+
+	  /* Get the right arglist by handling PASS/NOPASS.  */
+	  args = gfc_copy_actual_arglist (e->value.compcall.actual);
+	  if (!g->specific->nopass)
+	    {
+	      gfc_expr* po;
+	      po = extract_compcall_passed_object (e);
+	      if (!po)
+		return FAILURE;
+
+	      args = update_arglist_pass (args, po, g->specific->pass_arg_num);
+	    }
+
+	  /* Check if this arglist matches the formal.  */
+	  matches = gfc_compare_actual_formal (&args, target->formal, 1,
+					       target->attr.elemental, NULL);
+
+	  /* Clean up and break out of the loop if we've found it.  */
+	  gfc_free_actual_arglist (args);
+	  if (matches)
+	    {
+	      e->value.compcall.tbp = g->specific;
+	      goto success;
+	    }
+	}
+    }
+
+  /* Nothing matching found!  */
+  gfc_error ("Found no matching specific binding for the call to the GENERIC"
+	     " '%s' at %L", genname, &e->where);
+  return FAILURE;
+
+success:
+  return SUCCESS;
+}
+
+
 /* Resolve a call to a type-bound subroutine.  */
 
 static gfc_try
@@ -4377,6 +4464,17 @@ resolve_typebound_call (gfc_code* c)
   gfc_actual_arglist* newactual;
   gfc_symtree* target;
 
+  /* Check that's really a SUBROUTINE.  */
+  if (!c->expr->value.compcall.tbp->subroutine)
+    {
+      gfc_error ("'%s' at %L should be a SUBROUTINE",
+		 c->expr->value.compcall.name, &c->loc);
+      return FAILURE;
+    }
+
+  if (resolve_typebound_generic_call (c->expr) == FAILURE)
+    return FAILURE;
+
   /* Transform into an ordinary EXEC_CALL for now.  */
 
   if (resolve_typebound_static (c->expr, &target, &newactual) == FAILURE)
@@ -4402,13 +4500,27 @@ resolve_compcall (gfc_expr* e)
   gfc_actual_arglist* newactual;
   gfc_symtree* target;
 
-  /* For now, we simply transform it into a EXPR_FUNCTION call with the same
+  /* Check that's really a FUNCTION.  */
+  if (!e->value.compcall.tbp->function)
+    {
+      gfc_error ("'%s' at %L should be a FUNCTION",
+		 e->value.compcall.name, &e->where);
+      return FAILURE;
+    }
+
+  if (resolve_typebound_generic_call (e) == FAILURE)
+    return FAILURE;
+
+  /* For now, we simply transform it into an EXPR_FUNCTION call with the same
      arglist to the TBP's binding target.  */
 
   if (resolve_typebound_static (e, &target, &newactual) == FAILURE)
     return FAILURE;
 
   e->value.function.actual = newactual;
+  e->value.function.name = e->value.compcall.name;
+  e->value.function.isym = NULL;
+  e->value.function.esym = NULL;
   e->symtree = target;
   e->expr_type = EXPR_FUNCTION;
 
@@ -7771,9 +7883,20 @@ check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
   gfc_formal_arglist* proc_formal;
   gfc_formal_arglist* old_formal;
 
+  /* This procedure should only be called for non-GENERIC proc.  */
+  gcc_assert (!proc->typebound->is_generic);
+
+  /* If the overwritten procedure is GENERIC, this is an error.  */
+  if (old->typebound->is_generic)
+    {
+      gfc_error ("Can't overwrite GENERIC '%s' at %L",
+		 old->name, &proc->typebound->where);
+      return FAILURE;
+    }
+
   where = proc->typebound->where;
-  proc_target = proc->typebound->target->n.sym;
-  old_target = old->typebound->target->n.sym;
+  proc_target = proc->typebound->u.specific->n.sym;
+  old_target = old->typebound->u.specific->n.sym;
 
   /* Check that overridden binding is not NON_OVERRIDABLE.  */
   if (old->typebound->non_overridable)
@@ -7933,6 +8056,161 @@ check_typebound_override (gfc_symtree* proc, gfc_symtree* old)
 }
 
 
+/* Check if two GENERIC targets are ambiguous and emit an error is they are.  */
+
+static gfc_try
+check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2,
+			     const char* generic_name, locus where)
+{
+  gfc_symbol* sym1;
+  gfc_symbol* sym2;
+
+  gcc_assert (t1->specific && t2->specific);
+  gcc_assert (!t1->specific->is_generic);
+  gcc_assert (!t2->specific->is_generic);
+
+  sym1 = t1->specific->u.specific->n.sym;
+  sym2 = t2->specific->u.specific->n.sym;
+
+  /* Both must be SUBROUTINEs or both must be FUNCTIONs.  */
+  if (sym1->attr.subroutine != sym2->attr.subroutine
+      || sym1->attr.function != sym2->attr.function)
+    {
+      gfc_error ("'%s' and '%s' can't be mixed FUNCTION/SUBROUTINE for"
+		 " GENERIC '%s' at %L",
+		 sym1->name, sym2->name, generic_name, &where);
+      return FAILURE;
+    }
+
+  /* Compare the interfaces.  */
+  if (gfc_compare_interfaces (sym1, sym2, 1))
+    {
+      gfc_error ("'%s' and '%s' for GENERIC '%s' at %L are ambiguous",
+		 sym1->name, sym2->name, generic_name, &where);
+      return FAILURE;
+    }
+
+  return SUCCESS;
+}
+
+
+/* Resolve a GENERIC procedure binding for a derived type.  */
+
+static gfc_try
+resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st)
+{
+  gfc_tbp_generic* target;
+  gfc_symtree* first_target;
+  gfc_symbol* super_type;
+  gfc_symtree* inherited;
+  locus where;
+
+  gcc_assert (st->typebound);
+  gcc_assert (st->typebound->is_generic);
+
+  where = st->typebound->where;
+  super_type = gfc_get_derived_super_type (derived);
+
+  /* Find the overridden binding if any.  */
+  st->typebound->overridden = NULL;
+  if (super_type)
+    {
+      gfc_symtree* overridden;
+      overridden = gfc_find_typebound_proc (super_type, NULL, st->name, true);
+
+      if (overridden && overridden->typebound)
+	st->typebound->overridden = overridden->typebound;
+    }
+
+  /* Try to find the specific bindings for the symtrees in our target-list.  */
+  gcc_assert (st->typebound->u.generic);
+  for (target = st->typebound->u.generic; target; target = target->next)
+    if (!target->specific)
+      {
+	gfc_typebound_proc* overridden_tbp;
+	gfc_tbp_generic* g;
+	const char* target_name;
+
+	target_name = target->specific_st->name;
+
+	/* Defined for this type directly.  */
+	if (target->specific_st->typebound)
+	  {
+	    target->specific = target->specific_st->typebound;
+	    goto specific_found;
+	  }
+
+	/* Look for an inherited specific binding.  */
+	if (super_type)
+	  {
+	    inherited = gfc_find_typebound_proc (super_type, NULL,
+						 target_name, true);
+
+	    if (inherited)
+	      {
+		gcc_assert (inherited->typebound);
+		target->specific = inherited->typebound;
+		goto specific_found;
+	      }
+	  }
+
+	gfc_error ("Undefined specific binding '%s' as target of GENERIC '%s'"
+		   " at %L", target_name, st->name, &where);
+	return FAILURE;
+
+	/* Once we've found the specific binding, check it is not ambiguous with
+	   other specifics already found or inherited for the same GENERIC.  */
+specific_found:
+	gcc_assert (target->specific);
+
+	/* This must really be a specific binding!  */
+	if (target->specific->is_generic)
+	  {
+	    gfc_error ("GENERIC '%s' at %L must target a specific binding,"
+		       " '%s' is GENERIC, too", st->name, &where, target_name);
+	    return FAILURE;
+	  }
+
+	/* Check those already resolved on this type directly.  */
+	for (g = st->typebound->u.generic; g; g = g->next)
+	  if (g != target && g->specific
+	      && check_generic_tbp_ambiguity (target, g, st->name, where)
+		  == FAILURE)
+	    return FAILURE;
+
+	/* Check for ambiguity with inherited specific targets.  */
+	for (overridden_tbp = st->typebound->overridden; overridden_tbp;
+	     overridden_tbp = overridden_tbp->overridden)
+	  if (overridden_tbp->is_generic)
+	    {
+	      for (g = overridden_tbp->u.generic; g; g = g->next)
+		{
+		  gcc_assert (g->specific);
+		  if (check_generic_tbp_ambiguity (target, g,
+						   st->name, where) == FAILURE)
+		    return FAILURE;
+		}
+	    }
+      }
+
+  /* If we attempt to "overwrite" a specific binding, this is an error.  */
+  if (st->typebound->overridden && !st->typebound->overridden->is_generic)
+    {
+      gfc_error ("GENERIC '%s' at %L can't overwrite specific binding with"
+		 " the same name", st->name, &where);
+      return FAILURE;
+    }
+
+  /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as
+     all must have the same attributes here.  */
+  first_target = st->typebound->u.generic->specific->u.specific;
+  st->typebound->subroutine = first_target->n.sym->attr.subroutine;
+  st->typebound->function = first_target->n.sym->attr.function;
+
+  return SUCCESS;
+}
+
+
 /* Resolve the type-bound procedures for a derived type.  */
 
 static gfc_symbol* resolve_bindings_derived;
@@ -7951,9 +8229,19 @@ resolve_typebound_procedure (gfc_symtree* stree)
   if (!stree->typebound)
     return;
 
+  /* If this is a GENERIC binding, use that routine.  */
+  if (stree->typebound->is_generic)
+    {
+      if (resolve_typebound_generic (resolve_bindings_derived, stree)
+	    == FAILURE)
+	goto error;
+      return;
+    }
+
   /* Get the target-procedure to check it.  */
-  gcc_assert (stree->typebound->target);
-  proc = stree->typebound->target->n.sym;
+  gcc_assert (!stree->typebound->is_generic);
+  gcc_assert (stree->typebound->u.specific);
+  proc = stree->typebound->u.specific->n.sym;
   where = stree->typebound->where;
 
   /* Default access should already be resolved from the parser.  */
@@ -7970,14 +8258,17 @@ resolve_typebound_procedure (gfc_symtree* stree)
 		 " an explicit interface at %L", proc->name, &where);
       goto error;
     }
+  stree->typebound->subroutine = proc->attr.subroutine;
+  stree->typebound->function = proc->attr.function;
 
   /* Find the super-type of the current derived type.  We could do this once and
      store in a global if speed is needed, but as long as not I believe this is
      more readable and clearer.  */
   super_type = gfc_get_derived_super_type (resolve_bindings_derived);
 
-  /* If PASS, resolve and check arguments.  */
-  if (!stree->typebound->nopass)
+  /* If PASS, resolve and check arguments if not already resolved / loaded
+     from a .mod file.  */
+  if (!stree->typebound->nopass && stree->typebound->pass_arg_num == 0)
     {
       if (stree->typebound->pass_arg)
 	{
@@ -8039,12 +8330,16 @@ resolve_typebound_procedure (gfc_symtree* stree)
 
   /* If we are extending some type, check that we don't override a procedure
      flagged NON_OVERRIDABLE.  */
+  stree->typebound->overridden = NULL;
   if (super_type)
     {
       gfc_symtree* overridden;
       overridden = gfc_find_typebound_proc (super_type, NULL,
 					    stree->name, true);
 
+      if (overridden && overridden->typebound)
+	stree->typebound->overridden = overridden->typebound;
+
       if (overridden && check_typebound_override (stree, overridden) == FAILURE)
 	goto error;
     }
@@ -8121,6 +8416,10 @@ resolve_fl_derived (gfc_symbol *sym)
 
   super_type = gfc_get_derived_super_type (sym);
 
+  /* Ensure the extended type gets resolved before we do.  */
+  if (super_type && resolve_fl_derived (super_type) == FAILURE)
+    return FAILURE;
+
   for (c = sym->components; c != NULL; c = c->next)
     {
       /* If this type is an extension, see if this component has the same name