This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[Patch, Fortran] Handle GENERIC type-bound procedures


Hi,

this is a follow-up patch to my recent type-bound procedures
implementation to handle GENERIC bindings and it also includes some
minor tweaks to the general type-bound procedures handling.

GENERIC bindings are stored as gfc_symtree with gfc_typebound_proc
structure as are specific bindings, and their "targets" are kept in a
linked list of gfc_tbp_generic nodes referencing the targetted specific
bindings.

When a call to a GENERIC procedure is found, the target matching the
actual arglist is found and inserted in its stead during resolution.

There are two XXX comments in the source where I'd like to hear your
opinions, and I found a nasty, incomprehensible section in the standard
(16.2.3 Restrictions on generic declarations) that deals with
restrictions in respect to passed-object dummy arguments.  This section
is not yet implemented, I currently use the existing routines from
interface.c to check for ambiguous interfaces.  As I see it, this can
lead to possible accepts-invalid's in special cases that would allow
that a call to a GENERIC binding might have ambiguous actual arglists.
In such a case a "random one" of the targets would be picked and called.
  I suggest to open a PR for this and not handle it directly with this
patch as it is already quite big and I don't think I've understood that
section well enough to do it at the moment...

Apart from these points, the patch should be quite ready; if this gets
reviewed and checked-in before my documentation patch pending, I'll
update that to document GENERIC, too; otherwise I'll submit a new
documentation patch when GENERIC handling is checked in. Ok?

(Regression-tested on GNU/Linux-x86-32 without failures.)

So, and now I'm awaiting your comments...

Daniel

--
Done:     Arc-Bar-Cav-Sam-Val-Wiz, Dwa-Elf-Gno-Hum-Orc, Law-Neu-Cha, Fem-Mal
To go:    Hea-Kni-Mon-Pri-Ran-Rog-Tou

2008-08-30  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.
	(match_generic_in_type): New method.
	* 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.
	(parse_derived): Handle ST_GENERIC with an error.
	* 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-30  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.

Index: gcc/fortran/interface.c
===================================================================
--- gcc/fortran/interface.c	(revision 139725)
+++ gcc/fortran/interface.c	(working copy)
@@ -479,7 +479,6 @@ compare_type_rank (gfc_symbol *s1, gfc_s
 }
 
 
-static int compare_interfaces (gfc_symbol *, gfc_symbol *, int);
 static int compare_intr_interfaces (gfc_symbol *, gfc_symbol *);
 
 /* Given two symbols that are formal arguments, compare their types
@@ -954,8 +953,8 @@ generic_correspondence (gfc_formal_argli
    We return nonzero if there exists an actual argument list that
    would be ambiguous between the two interfaces, zero otherwise.  */
 
-static int
-compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
+int
+gfc_compare_interfaces (gfc_symbol *s1, gfc_symbol *s2, int generic_flag)
 {
   gfc_formal_arglist *f1, *f2;
 
@@ -1173,7 +1172,7 @@ check_interface1 (gfc_interface *p, gfc_
 	if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
 	  continue;
 
-	if (compare_interfaces (p->sym, q->sym, generic_flag))
+	if (gfc_compare_interfaces (p->sym, q->sym, generic_flag))
 	  {
 	    if (referenced)
 	      {
@@ -1460,7 +1459,7 @@ compare_parameter (gfc_symbol *formal, g
 	 if (!compare_intr_interfaces (formal, actual->symtree->n.sym))
 	   goto proc_fail;
 	}
-      else if (!compare_interfaces (formal, actual->symtree->n.sym, 0))
+      else if (!gfc_compare_interfaces (formal, actual->symtree->n.sym, 0))
 	goto proc_fail;
 
       return 1;
@@ -1819,9 +1818,9 @@ has_vector_subscript (gfc_expr *e)
    errors when things don't match instead of just returning the status
    code.  */
 
-static int
-compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
-		       int ranks_must_agree, int is_elemental, locus *where)
+int
+gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
+      			   int ranks_must_agree, int is_elemental, locus *where)
 {
   gfc_actual_arglist **new_arg, *a, *actual, temp;
   gfc_formal_arglist *f;
@@ -2449,8 +2448,8 @@ gfc_procedure_use (gfc_symbol *sym, gfc_
       return;
     }
 
-  if (!compare_actual_formal (ap, sym->formal, 0,
-			      sym->attr.elemental, where))
+  if (!gfc_compare_actual_formal (ap, sym->formal, 0,
+		  		  sym->attr.elemental, where))
     return;
 
   check_intents (sym->formal, *ap);
@@ -2479,7 +2478,7 @@ gfc_search_interface (gfc_interface *int
 
       r = !intr->sym->attr.elemental;
 
-      if (compare_actual_formal (ap, intr->sym->formal, r, !r, NULL))
+      if (gfc_compare_actual_formal (ap, intr->sym->formal, r, !r, NULL))
 	{
 	  check_intents (intr->sym->formal, *ap);
 	  if (gfc_option.warn_aliasing)
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 139725)
+++ gcc/fortran/symbol.c	(working copy)
@@ -4278,11 +4278,8 @@ gfc_find_typebound_proc (gfc_symbol* der
   /* Try to find it in the current type's namespace.  */
   gcc_assert (derived->f2k_derived);
   res = gfc_find_symtree (derived->f2k_derived->sym_root, name);
-  if (res)
+  if (res && res->typebound)
     {
-      if (!res->typebound)
-	return NULL;
-
       /* We found one.  */
       if (t)
 	*t = SUCCESS;
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c	(revision 139725)
+++ gcc/fortran/decl.c	(working copy)
@@ -4366,6 +4366,37 @@ gfc_match_procedure (void)
 }
 
 
+/* Delegating matcher for GENERIC.  */
+
+static match match_generic_in_type (void);
+
+/* XXX: Should I incorporate this and match_generic_in_type?  */
+
+match
+gfc_match_generic (void)
+{
+  match m;
+
+  switch (gfc_current_state ())
+    {
+    case COMP_DERIVED_CONTAINS:
+      m = match_generic_in_type ();
+      break;
+    default:
+      return MATCH_NO;
+    }
+
+  if (m != MATCH_YES)
+    return m;
+
+  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: GENERIC binding at %C")
+      == FAILURE)
+    return MATCH_ERROR;
+
+  return m;
+}
+
+
 /* Warn if a matched procedure has the same name as an intrinsic; this is
    simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
    parser-state-stack to find out whether we're in a module.  */
@@ -6721,7 +6752,7 @@ cleanup:
 /* Match binding attributes.  */
 
 static match
-match_binding_attributes (gfc_typebound_proc* ba)
+match_binding_attributes (gfc_typebound_proc* ba, bool generic)
 {
   bool found_passing = false;
   match m;
@@ -6736,120 +6767,135 @@ match_binding_attributes (gfc_typebound_
 
   /* If we find a comma, we believe there are binding attributes.  */
   if (gfc_match_char (',') == MATCH_NO)
-    return MATCH_NO;
+    {
+      ba->access = gfc_typebound_default_access;
+      return MATCH_NO;
+    }
 
   do
     {
-      /* NOPASS flag.  */
-      m = gfc_match (" nopass");
+      /* Access specifier.  */
+
+      m = gfc_match (" public");
       if (m == MATCH_ERROR)
 	goto error;
       if (m == MATCH_YES)
 	{
-	  if (found_passing)
+	  if (ba->access != ACCESS_UNKNOWN)
 	    {
-	      gfc_error ("Binding attributes already specify passing, illegal"
-			 " NOPASS at %C");
+	      gfc_error ("Duplicate access-specifier at %C");
 	      goto error;
 	    }
 
-	  found_passing = true;
-	  ba->nopass = 1;
+	  ba->access = ACCESS_PUBLIC;
 	  continue;
 	}
 
-      /* NON_OVERRIDABLE flag.  */
-      m = gfc_match (" non_overridable");
+      m = gfc_match (" private");
       if (m == MATCH_ERROR)
 	goto error;
       if (m == MATCH_YES)
 	{
-	  if (ba->non_overridable)
+	  if (ba->access != ACCESS_UNKNOWN)
 	    {
-	      gfc_error ("Duplicate NON_OVERRIDABLE at %C");
+	      gfc_error ("Duplicate access-specifier at %C");
 	      goto error;
 	    }
 
-	  ba->non_overridable = 1;
+	  ba->access = ACCESS_PRIVATE;
 	  continue;
 	}
 
-      /* DEFERRED flag.  */
-      /* TODO: Handle really once implemented.  */
-      m = gfc_match (" deferred");
-      if (m == MATCH_ERROR)
-	goto error;
-      if (m == MATCH_YES)
-	{
-	  gfc_error ("DEFERRED not yet implemented at %C");
-	  goto error;
-	}
-
-      /* PASS possibly including argument.  */
-      m = gfc_match (" pass");
-      if (m == MATCH_ERROR)
-	goto error;
-      if (m == MATCH_YES)
+      /* If inside GENERIC, the following is not allowed.  */
+      if (!generic)
 	{
-	  char arg[GFC_MAX_SYMBOL_LEN + 1];
 
-	  if (found_passing)
+	  /* NOPASS flag.  */
+	  m = gfc_match (" nopass");
+	  if (m == MATCH_ERROR)
+	    goto error;
+	  if (m == MATCH_YES)
 	    {
-	      gfc_error ("Binding attributes already specify passing, illegal"
-			 " PASS at %C");
-	      goto error;
+	      if (found_passing)
+		{
+		  gfc_error ("Binding attributes already specify passing,"
+			     " illegal NOPASS at %C");
+		  goto error;
+		}
+
+	      found_passing = true;
+	      ba->nopass = 1;
+	      continue;
 	    }
 
-	  m = gfc_match (" ( %n )", arg);
+	  /* NON_OVERRIDABLE flag.  */
+	  m = gfc_match (" non_overridable");
 	  if (m == MATCH_ERROR)
 	    goto error;
 	  if (m == MATCH_YES)
-	    ba->pass_arg = xstrdup (arg);
-	  gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
-
-	  found_passing = true;
-	  ba->nopass = 0;
-	  continue;
-	}
+	    {
+	      if (ba->non_overridable)
+		{
+		  gfc_error ("Duplicate NON_OVERRIDABLE at %C");
+		  goto error;
+		}
 
-      /* Access specifier.  */
+	      ba->non_overridable = 1;
+	      continue;
+	    }
 
-      m = gfc_match (" public");
-      if (m == MATCH_ERROR)
-	goto error;
-      if (m == MATCH_YES)
-	{
-	  if (ba->access != ACCESS_UNKNOWN)
+	  /* DEFERRED flag.  */
+	  /* TODO: Handle really once implemented.  */
+	  m = gfc_match (" deferred");
+	  if (m == MATCH_ERROR)
+	    goto error;
+	  if (m == MATCH_YES)
 	    {
-	      gfc_error ("Duplicate access-specifier at %C");
+	      gfc_error ("DEFERRED not yet implemented at %C");
 	      goto error;
 	    }
 
-	  ba->access = ACCESS_PUBLIC;
-	  continue;
-	}
-
-      m = gfc_match (" private");
-      if (m == MATCH_ERROR)
-	goto error;
-      if (m == MATCH_YES)
-	{
-	  if (ba->access != ACCESS_UNKNOWN)
+	  /* PASS possibly including argument.  */
+	  m = gfc_match (" pass");
+	  if (m == MATCH_ERROR)
+	    goto error;
+	  if (m == MATCH_YES)
 	    {
-	      gfc_error ("Duplicate access-specifier at %C");
-	      goto error;
+	      char arg[GFC_MAX_SYMBOL_LEN + 1];
+
+	      if (found_passing)
+		{
+		  gfc_error ("Binding attributes already specify passing,"
+			     " illegal PASS at %C");
+		  goto error;
+		}
+
+	      m = gfc_match (" ( %n )", arg);
+	      if (m == MATCH_ERROR)
+		goto error;
+	      if (m == MATCH_YES)
+		ba->pass_arg = xstrdup (arg);
+	      gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
+
+	      found_passing = true;
+	      ba->nopass = 0;
+	      continue;
 	    }
 
-	  ba->access = ACCESS_PRIVATE;
-	  continue;
 	}
 
       /* Nothing matching found.  */
-      gfc_error ("Expected binding attribute at %C");
+      if (generic)
+	gfc_error ("Expected access-specifier at %C");
+      else
+	gfc_error ("Expected binding attribute at %C");
       goto error;
     }
   while (gfc_match_char (',') == MATCH_YES);
 
+  if (ba->access == ACCESS_UNKNOWN)
+    ba->access = gfc_typebound_default_access;
+
   return MATCH_YES;
 
 error:
@@ -6890,9 +6936,10 @@ match_procedure_in_type (void)
   /* Construct the data structure.  */
   tb = gfc_get_typebound_proc ();
   tb->where = gfc_current_locus;
+  tb->is_generic = 0;
 
   /* Match binding attributes.  */
-  m = match_binding_attributes (tb);
+  m = match_binding_attributes (tb, false);
   if (m == MATCH_ERROR)
     return m;
   seen_attrs = (m == MATCH_YES);
@@ -6962,9 +7009,10 @@ match_procedure_in_type (void)
   gcc_assert (ns);
 
   /* See if we already have a binding with this name in the symtree which would
-     be an error.  */
+     be an error.  If a GENERIC already targetted this binding, it may be
+     already there but then typebound is still NULL.  */
   stree = gfc_find_symtree (ns->sym_root, name);
-  if (stree)
+  if (stree && stree->typebound)
     {
       gfc_error ("There's already a procedure with binding name '%s' for the"
 		 " derived type '%s' at %C", name, block->name);
@@ -6974,14 +7022,140 @@ match_procedure_in_type (void)
   /* Insert it and set attributes.  */
   if (gfc_get_sym_tree (name, ns, &stree))
     return MATCH_ERROR;
-  if (gfc_get_sym_tree (target, gfc_current_ns, &tb->target))
+  if (gfc_get_sym_tree (target, gfc_current_ns, &tb->u.specific))
     return MATCH_ERROR;
+  gfc_set_sym_referenced (tb->u.specific->n.sym);
   stree->typebound = tb;
 
   return MATCH_YES;
 }
 
 
+/* Match a GENERIC procedure binding inside a derived type.  */
+
+static match
+match_generic_in_type (void)
+{
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  gfc_symbol* block;
+  gfc_typebound_proc tbattr; /* Used for match_binding_attributes.  */
+  gfc_typebound_proc* tb;
+  gfc_symtree* st;
+  gfc_namespace* ns;
+  match m;
+
+  /* Check current state.  */
+  gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS);
+  block = gfc_state_stack->previous->sym;
+  ns = block->f2k_derived;
+  gcc_assert (block && ns);
+
+  /* See if we get an access-specifier.  */
+  m = match_binding_attributes (&tbattr, true);
+  if (m == MATCH_ERROR)
+    goto error;
+
+  /* Now the colons, those are required.  */
+  if (gfc_match (" ::") != MATCH_YES)
+    {
+      gfc_error ("Expected '::' at %C");
+      goto error;
+    }
+
+  /* The binding name and =>.  */
+  m = gfc_match (" %n =>", name);
+  if (m == MATCH_ERROR)
+    return MATCH_ERROR;
+  if (m == MATCH_NO)
+    {
+      gfc_error ("Expected generic name at %C");
+      goto error;
+    }
+
+  /* If there's already something with this name, check that it is another
+     GENERIC and then extend that rather than build a new node.  */
+  st = gfc_find_symtree (ns->sym_root, name);
+  if (st)
+    {
+      if (!st->typebound || !st->typebound->is_generic)
+	{
+	  gfc_error ("There's already a non-generic procedure with binding name"
+		     " '%s' for the derived type '%s' at %C",
+		     name, block->name);
+	  goto error;
+	}
+
+      tb = st->typebound;
+      if (tb->access != tbattr.access)
+	{
+	  gfc_error ("Binding at %C must have the same access as already"
+		     " defined binding '%s'", name);
+	  goto error;
+	}
+    }
+  else
+    {
+      if (gfc_get_sym_tree (name, ns, &st))
+	return MATCH_ERROR;
+
+      st->typebound = tb = gfc_get_typebound_proc ();
+      tb->where = gfc_current_locus;
+      tb->access = tbattr.access;
+      tb->is_generic = 1;
+      tb->u.generic = NULL;
+    }
+
+  /* Now, match all following names as specific targets.  */
+  do
+    {
+      gfc_symtree* target_st;
+      gfc_tbp_generic* target;
+
+      m = gfc_match_name (name);
+      if (m == MATCH_ERROR)
+	goto error;
+      if (m == MATCH_NO)
+	{
+	  gfc_error ("Expected specific binding name at %C");
+	  goto error;
+	}
+
+      if (gfc_get_sym_tree (name, ns, &target_st))
+	goto error;
+
+      /* See if this is a duplicate specification.  */
+      for (target = tb->u.generic; target; target = target->next)
+	if (target_st == target->specific_st)
+	  {
+	    gfc_error ("'%s' already defined as specific binding for the"
+		       " generic '%s' at %C", name, st->n.sym->name);
+	    goto error;
+	  }
+
+      gfc_set_sym_referenced (target_st->n.sym);
+
+      target = gfc_get_tbp_generic ();
+      target->specific_st = target_st;
+      target->specific = NULL;
+      target->next = tb->u.generic;
+      tb->u.generic = target;
+    }
+  while (gfc_match (" ,") == MATCH_YES);
+
+  /* Here should be the end.  */
+  if (gfc_match_eos () != MATCH_YES)
+    {
+      gfc_error ("Junk after GENERIC binding at %C");
+      goto error;
+    }
+
+  return MATCH_YES;
+
+error:
+  return MATCH_ERROR;
+}
+
+
 /* Match a FINAL declaration inside a derived type.  */
 
 match
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 139725)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -229,7 +229,7 @@ typedef enum
   ST_OMP_PARALLEL, ST_OMP_PARALLEL_DO, ST_OMP_PARALLEL_SECTIONS,
   ST_OMP_PARALLEL_WORKSHARE, ST_OMP_SECTIONS, ST_OMP_SECTION, ST_OMP_SINGLE,
   ST_OMP_THREADPRIVATE, ST_OMP_WORKSHARE, ST_OMP_TASK, ST_OMP_END_TASK,
-  ST_OMP_TASKWAIT, ST_PROCEDURE,
+  ST_OMP_TASKWAIT, ST_PROCEDURE, ST_GENERIC,
   ST_GET_FCN_CHARACTERISTICS, ST_NONE
 }
 gfc_statement;
@@ -992,15 +992,40 @@ typedef struct
 gfc_user_op;
 
 
+/* A list of specific bindings that are associated with a generic spec.  */
+typedef struct gfc_tbp_generic
+{
+  /* The parser sets specific_st, upon resolution we look for the corresponding
+     gfc_typebound_proc and set specific for further use.  */
+  struct gfc_symtree* specific_st;
+  struct gfc_typebound_proc* specific;
+
+  struct gfc_tbp_generic* next;
+}
+gfc_tbp_generic;
+
+#define gfc_get_tbp_generic() XCNEW (gfc_tbp_generic)
+
+
 /* Data needed for type-bound procedures.  */
-typedef struct
+typedef struct gfc_typebound_proc
 {
-  struct gfc_symtree* target;
-  locus where; /* Where the PROCEDURE definition was.  */
+  locus where; /* Where the PROCEDURE/GENERIC definition was.  */
+
+  union
+  {
+    struct gfc_symtree* specific;
+    gfc_tbp_generic* generic;
+  }
+  u;
 
   gfc_access access;
   char* pass_arg; /* Argument-name for PASS.  NULL if not specified.  */
 
+  /* The overridden type-bound proc (or GENERIC with this name in the
+     parent-type) or NULL if non.  */
+  struct gfc_typebound_proc* overridden;
+
   /* Once resolved, we use the position of pass_arg in the formal arglist of
      the binding-target procedure to identify it.  The first argument has
      number 1 here, the second 2, and so on.  */
@@ -1008,6 +1033,8 @@ typedef struct
 
   unsigned nopass:1; /* Whether we have NOPASS (PASS otherwise).  */
   unsigned non_overridable:1;
+  unsigned is_generic:1;
+  unsigned function:1, subroutine:1;
 }
 gfc_typebound_proc;
 
@@ -1532,7 +1559,9 @@ typedef struct gfc_expr
     struct
     {
       gfc_actual_arglist* actual;
-      gfc_symtree* tbp;
+      gfc_typebound_proc* tbp;
+      gfc_symbol* derived;
+      const char* name;
     }
     compcall;
 
@@ -2439,6 +2468,7 @@ int gfc_is_compile_time_shape (gfc_array
 void gfc_free_interface (gfc_interface *);
 int gfc_compare_derived_types (gfc_symbol *, gfc_symbol *);
 int gfc_compare_types (gfc_typespec *, gfc_typespec *);
+int gfc_compare_interfaces (gfc_symbol*, gfc_symbol*, int);
 void gfc_check_interfaces (gfc_namespace *);
 void gfc_procedure_use (gfc_symbol *, gfc_actual_arglist **, locus *);
 gfc_symbol *gfc_search_interface (gfc_interface *, int,
@@ -2450,6 +2480,8 @@ gfc_try gfc_add_interface (gfc_symbol *)
 gfc_interface *gfc_current_interface_head (void);
 void gfc_set_current_interface_head (gfc_interface *);
 gfc_symtree* gfc_find_sym_in_symtree (gfc_symbol*);
+int gfc_compare_actual_formal (gfc_actual_arglist**, gfc_formal_arglist*,
+      			       int, int, locus*);
 
 /* io.c */
 extern gfc_st_label format_asterisk;
Index: gcc/fortran/module.c
===================================================================
--- gcc/fortran/module.c	(revision 139725)
+++ gcc/fortran/module.c	(working copy)
@@ -1708,6 +1708,12 @@ static const mstring binding_overriding[
     minit ("NON_OVERRIDABLE", 1),
     minit (NULL, -1)
 };
+static const mstring binding_generic[] =
+{
+    minit ("SPECIFIC", 0),
+    minit ("GENERIC", 1),
+    minit (NULL, -1)
+};
 
 
 /* Specialization of mio_name.  */
@@ -3199,6 +3205,8 @@ mio_namespace_ref (gfc_namespace **nsp)
 
 /* Save/restore the f2k_derived namespace of a derived-type symbol.  */
 
+static gfc_namespace* current_f2k_derived;
+
 static void
 mio_typebound_proc (gfc_typebound_proc** proc)
 {
@@ -3212,13 +3220,13 @@ mio_typebound_proc (gfc_typebound_proc**
   gcc_assert (*proc);
 
   mio_lparen ();
-  mio_symtree_ref (&(*proc)->target);
 
   (*proc)->access = MIO_NAME (gfc_access) ((*proc)->access, access_types);
 
   (*proc)->nopass = mio_name ((*proc)->nopass, binding_passing);
   (*proc)->non_overridable = mio_name ((*proc)->non_overridable,
 				       binding_overriding);
+  (*proc)->is_generic = mio_name ((*proc)->is_generic, binding_generic);
 
   if (iomode == IO_INPUT)
     (*proc)->pass_arg = NULL;
@@ -3227,6 +3235,38 @@ mio_typebound_proc (gfc_typebound_proc**
   mio_integer (&flag);
   (*proc)->pass_arg_num = (unsigned) flag;
 
+  if ((*proc)->is_generic)
+    {
+      gfc_tbp_generic* g;
+
+      mio_lparen ();
+
+      if (iomode == IO_OUTPUT)
+	for (g = (*proc)->u.generic; g; g = g->next)
+	  mio_allocated_string (g->specific_st->name);
+      else
+	{
+	  (*proc)->u.generic = NULL;
+	  while (peek_atom () != ATOM_RPAREN)
+	    {
+	      g = gfc_get_tbp_generic ();
+	      g->specific = NULL;
+
+	      require_atom (ATOM_STRING);
+	      gfc_get_sym_tree (atom_string, current_f2k_derived,
+				&g->specific_st);
+	      gfc_free (atom_string);
+
+	      g->next = (*proc)->u.generic;
+	      (*proc)->u.generic = g;
+	    }
+	}
+
+      mio_rparen ();
+    }
+  else
+    mio_symtree_ref (&(*proc)->u.specific);
+
   mio_rparen ();
 }
 
@@ -3270,6 +3310,8 @@ mio_finalizer (gfc_finalizer **f)
 static void
 mio_f2k_derived (gfc_namespace *f2k)
 {
+  current_f2k_derived = f2k;
+
   /* Handle the list of finalizer procedures.  */
   mio_lparen ();
   if (iomode == IO_OUTPUT)
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 139725)
+++ gcc/fortran/resolve.c	(working copy)
@@ -4306,16 +4306,14 @@ update_arglist_pass (gfc_actual_arglist*
 }
 
 
-/* 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, g
 			  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, g
 }
 
 
+/* 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 hierarchie.  */
+  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* p
   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,178 @@ check_typebound_override (gfc_symtree* p
 }
 
 
+/* 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.  */
+	/* XXX: Do we have to do access checking here?  What's about this code:
+
+	   MODULE m1
+	    TYPE t1
+	    CONTAINS
+	      PROCEDURE, PRIVATE :: proc
+	    END TYPE t1
+	   END MODULE m1
+
+	   MODULE m2
+	    TYPE t2
+	    CONTAINS
+	      GENERIC :: gen => proc
+	    END TYPE t2
+	   END MODULE m2
+
+	   Is this valid or invalid?  */
+	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 +8246,19 @@ resolve_typebound_procedure (gfc_symtree
   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 +8275,17 @@ resolve_typebound_procedure (gfc_symtree
 		 " 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 +8347,16 @@ resolve_typebound_procedure (gfc_symtree
 
   /* 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 +8433,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
Index: gcc/fortran/st.c
===================================================================
--- gcc/fortran/st.c	(revision 139725)
+++ gcc/fortran/st.c	(working copy)
@@ -109,7 +109,6 @@ gfc_free_statement (gfc_code *p)
       break;
 
     case EXEC_COMPCALL:
-      gfc_free_expr (p->expr);
     case EXEC_CALL:
     case EXEC_ASSIGN_CALL:
       gfc_free_actual_arglist (p->ext.actual);
Index: gcc/fortran/match.c
===================================================================
--- gcc/fortran/match.c	(revision 139725)
+++ gcc/fortran/match.c	(working copy)
@@ -2525,6 +2525,7 @@ match_typebound_call (gfc_symtree* varst
   base->expr_type = EXPR_VARIABLE;
   base->symtree = varst;
   base->where = gfc_current_locus;
+  gfc_set_sym_referenced (varst->n.sym);
   
   m = gfc_match_varspec (base, 0, true);
   if (m == MATCH_NO)
Index: gcc/fortran/match.h
===================================================================
--- gcc/fortran/match.h	(revision 139725)
+++ gcc/fortran/match.h	(working copy)
@@ -36,6 +36,9 @@ extern gfc_st_label *gfc_statement_label
 extern int gfc_matching_procptr_assignment;
 extern bool gfc_matching_prefix;
 
+/* Default access specifier while matching procedure bindings.  */
+extern gfc_access gfc_typebound_default_access;
+
 /****************** All gfc_match* routines *****************/
 
 /* match.c.  */
@@ -141,6 +144,7 @@ match gfc_match_end (gfc_statement *);
 match gfc_match_data_decl (void);
 match gfc_match_formal_arglist (gfc_symbol *, int, int);
 match gfc_match_procedure (void);
+match gfc_match_generic (void);
 match gfc_match_function_decl (void);
 match gfc_match_entry (void);
 match gfc_match_subroutine (void);
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c	(revision 139725)
+++ gcc/fortran/parse.c	(working copy)
@@ -372,6 +372,7 @@ decode_statement (void)
       break;
 
     case 'g':
+      match ("generic", gfc_match_generic, ST_GENERIC);
       match ("go to", gfc_match_goto, ST_GOTO);
       break;
 
@@ -1195,6 +1196,9 @@ gfc_ascii_statement (gfc_statement st)
     case ST_FUNCTION:
       p = "FUNCTION";
       break;
+    case ST_GENERIC:
+      p = "GENERIC";
+      break;
     case ST_GOTO:
       p = "GOTO";
       break;
@@ -1691,21 +1695,10 @@ unexpected_eof (void)
 }
 
 
-/* Set the default access attribute for a typebound procedure; this is used
-   as callback for gfc_traverse_symtree.  */
-
-static gfc_access typebound_default_access;
-
-static void
-set_typebound_default_access (gfc_symtree* stree)
-{
-  if (stree->typebound && stree->typebound->access == ACCESS_UNKNOWN)
-    stree->typebound->access = typebound_default_access;
-}
-
-
 /* Parse the CONTAINS section of a derived type definition.  */
 
+gfc_access gfc_typebound_default_access;
+
 static bool
 parse_derived_contains (void)
 {
@@ -1730,6 +1723,8 @@ parse_derived_contains (void)
   accept_statement (ST_CONTAINS);
   push_state (&s, COMP_DERIVED_CONTAINS, NULL);
 
+  gfc_typebound_default_access = ACCESS_PUBLIC;
+
   to_finish = false;
   while (!to_finish)
     {
@@ -1755,6 +1750,15 @@ parse_derived_contains (void)
 	  seen_comps = true;
 	  break;
 
+	case ST_GENERIC:
+	  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003:  GENERIC binding"
+					     " at %C") == FAILURE)
+	    error_flag = true;
+
+	  accept_statement (ST_GENERIC);
+	  seen_comps = true;
+	  break;
+
 	case ST_FINAL:
 	  if (gfc_notify_std (GFC_STD_F2003,
 			      "Fortran 2003:  FINAL procedure declaration"
@@ -1801,6 +1805,7 @@ parse_derived_contains (void)
 	    }
 
 	  accept_statement (ST_PRIVATE);
+	  gfc_typebound_default_access = ACCESS_PRIVATE;
 	  seen_private = true;
 	  break;
 
@@ -1823,12 +1828,6 @@ parse_derived_contains (void)
   pop_state ();
   gcc_assert (gfc_current_state () == COMP_DERIVED);
 
-  /* Walk the parsed type-bound procedures and set ACCESS_UNKNOWN attributes
-     to PUBLIC or PRIVATE depending on seen_private.  */
-  typebound_default_access = (seen_private ? ACCESS_PRIVATE : ACCESS_PUBLIC);
-  gfc_traverse_symtree (gfc_current_block ()->f2k_derived->sym_root,
-			&set_typebound_default_access);
-
   return error_flag;
 }
 
@@ -1875,6 +1874,11 @@ parse_derived (void)
 	  error_flag = 1;
 	  break;
 
+	case ST_GENERIC:
+	  gfc_error ("GENERIC binding at %C must be inside CONTAINS");
+	  error_flag = 1;
+	  break;
+
 	case ST_FINAL:
 	  gfc_error ("FINAL declaration at %C must be inside CONTAINS");
 	  error_flag = 1;
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(revision 139725)
+++ gcc/fortran/primary.c	(working copy)
@@ -1709,7 +1709,6 @@ gfc_match_varspec (gfc_expr *primary, in
   gfc_ref *substring, *tail;
   gfc_component *component;
   gfc_symbol *sym = primary->symtree->n.sym;
-  gfc_symtree *tbp;
   match m;
   bool unknown;
 
@@ -1754,6 +1753,7 @@ gfc_match_varspec (gfc_expr *primary, in
   for (;;)
     {
       gfc_try t;
+      gfc_symtree *tbp;
 
       m = gfc_match_name (name);
       if (m == MATCH_NO)
@@ -1772,13 +1772,20 @@ gfc_match_varspec (gfc_expr *primary, in
 	  gcc_assert (!tail || !tail->next);
 	  gcc_assert (primary->expr_type == EXPR_VARIABLE);
 
-	  tbp_sym = tbp->typebound->target->n.sym;
+	  if (tbp->typebound->is_generic)
+	    tbp_sym = NULL;
+	  else
+	    tbp_sym = tbp->typebound->u.specific->n.sym;
 
 	  primary->expr_type = EXPR_COMPCALL;
-	  primary->value.compcall.tbp = tbp;
-	  primary->ts = tbp_sym->ts;
+	  primary->value.compcall.tbp = tbp->typebound;
+	  primary->value.compcall.derived = sym;
+	  primary->value.compcall.name = tbp->name;
+	  gcc_assert (primary->symtree->n.sym->attr.referenced);
+	  if (tbp_sym)
+	    primary->ts = tbp_sym->ts;
 
-	  m = gfc_match_actual_arglist (tbp_sym->attr.subroutine,
+	  m = gfc_match_actual_arglist (tbp->typebound->subroutine,
 					&primary->value.compcall.actual);
 	  if (m == MATCH_ERROR)
 	    return MATCH_ERROR;
@@ -1793,16 +1800,7 @@ gfc_match_varspec (gfc_expr *primary, in
 		}
 	    }
 
-	  if (sub_flag && !tbp_sym->attr.subroutine)
-	    {
-	      gfc_error ("'%s' at %C should be a SUBROUTINE", name);
-	      return MATCH_ERROR;
-	    }
-	  if (!sub_flag && !tbp_sym->attr.function)
-	    {
-	      gfc_error ("'%s' at %C should be a FUNCTION", name);
-	      return MATCH_ERROR;
-	    }
+	  gfc_set_sym_referenced (tbp->n.sym);
 
 	  break;
 	}
Index: gcc/testsuite/gfortran.dg/typebound_generic_1.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_generic_1.f03	(revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_generic_1.f03	(revision 0)
@@ -0,0 +1,95 @@
+! { dg-do compile }
+
+! Type-bound procedures
+! Compiling and errors with GENERIC binding declarations.
+! Bindings with NOPASS.
+
+MODULE m
+  IMPLICIT NONE
+
+  TYPE somet
+  CONTAINS
+    PROCEDURE, NOPASS :: p1 => intf1
+    PROCEDURE, NOPASS :: p1a => intf1a
+    PROCEDURE, NOPASS :: p2 => intf2
+    PROCEDURE, NOPASS :: p3 => intf3
+    PROCEDURE, NOPASS :: subr
+
+    GENERIC :: gen1 => p1a ! { dg-error "are ambiguous" }
+
+    GENERIC, PUBLIC :: gen1 => p1, p2
+    GENERIC :: gen1 => p3 ! Implicitelly PUBLIC.
+    GENERIC, PRIVATE :: gen2 => p1
+
+    GENERIC :: gen2 => p2 ! { dg-error "same access" }
+    GENERIC :: gen1 => p1 ! { dg-error "already defined as specific binding" }
+    GENERIC, PASS :: gen3 => p1 ! { dg-error "Expected access-specifier" }
+    GENERIC :: p1 => p1 ! { dg-error "already a non-generic procedure" }
+    PROCEDURE, NOPASS :: gen1 => intf1 ! { dg-error "already a procedure" }
+    GENERIC :: gen3 => ! { dg-error "specific binding" }
+    GENERIC :: gen4 => p1 x ! { dg-error "Junk after" }
+    GENERIC :: gen4 => p_notthere ! { dg-error "Undefined specific binding" }
+    GENERIC :: gen5 => gen1 ! { dg-error "must target a specific binding" }
+
+    GENERIC :: gensubr => p2 ! { dg-error "mixed FUNCTION/SUBROUTINE" }
+    GENERIC :: gensubr => subr
+
+  END TYPE somet
+
+  TYPE supert
+  CONTAINS
+    PROCEDURE, NOPASS :: p1 => intf1
+    PROCEDURE, NOPASS :: p1a => intf1a
+    PROCEDURE, NOPASS :: p2 => intf2
+    PROCEDURE, NOPASS :: p3 => intf3
+    PROCEDURE, NOPASS :: sub1 => subr
+
+    GENERIC :: gen1 => p1, p2
+    GENERIC :: gen1 => p3
+    GENERIC :: gen2 => p1
+    GENERIC :: gensub => sub1
+  END TYPE supert
+
+  TYPE, EXTENDS(supert) :: t
+  CONTAINS
+    GENERIC :: gen2 => p1a ! { dg-error "are ambiguous" }
+    GENERIC :: gen2 => p3
+    GENERIC :: p1 => p2 ! { dg-error "can't overwrite specific" }
+    GENERIC :: gensub => p2 ! { dg-error "mixed FUNCTION/SUBROUTINE" }
+
+    PROCEDURE, NOPASS :: gen1 => intf1 ! { dg-error "Can't overwrite GENERIC" }
+  END TYPE t
+
+CONTAINS
+
+  INTEGER FUNCTION intf1 (a, b)
+    IMPLICIT NONE
+    INTEGER :: a, b
+    intf1 = 42
+  END FUNCTION intf1
+
+  INTEGER FUNCTION intf1a (a, b)
+    IMPLICIT NONE
+    INTEGER :: a, b
+    intf1a = 42
+  END FUNCTION intf1a
+
+  INTEGER FUNCTION intf2 (a, b)
+    IMPLICIT NONE
+    REAL :: a, b
+    intf2 = 42.0
+  END FUNCTION intf2
+
+  LOGICAL FUNCTION intf3 ()
+    IMPLICIT NONE
+    intf3 = .TRUE.
+  END FUNCTION intf3
+
+  SUBROUTINE subr (x)
+    IMPLICIT NONE
+    INTEGER :: x
+  END SUBROUTINE subr
+
+END MODULE m
+
+! { dg-final { cleanup-modules "m" } }
Index: gcc/testsuite/gfortran.dg/typebound_generic_2.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_generic_2.f03	(revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_generic_2.f03	(revision 0)
@@ -0,0 +1,64 @@
+! { dg-do compile }
+
+! Type-bound procedures
+! Check for errors with calls to GENERIC bindings and their module IO.
+! Calls with NOPASS.
+
+MODULE m
+  IMPLICIT NONE
+
+  TYPE supert
+  CONTAINS
+    PROCEDURE, NOPASS :: func_int
+    PROCEDURE, NOPASS :: sub_int
+    GENERIC :: func => func_int
+    GENERIC :: sub => sub_int
+  END TYPE supert
+
+  TYPE, EXTENDS(supert) :: t
+  CONTAINS
+    PROCEDURE, NOPASS :: func_real
+    GENERIC :: func => func_real
+  END TYPE t
+
+CONTAINS
+
+  INTEGER FUNCTION func_int (x)
+    IMPLICIT NONE
+    INTEGER :: x
+    func_int = x
+  END FUNCTION func_int
+
+  INTEGER FUNCTION func_real (x)
+    IMPLICIT NONE
+    REAL :: x
+    func_real = INT(x * 4.2)
+  END FUNCTION func_real
+
+  SUBROUTINE sub_int (x)
+    IMPLICIT NONE
+    INTEGER :: x
+  END SUBROUTINE sub_int
+
+END MODULE m
+
+PROGRAM main
+  USE m
+  IMPLICIT NONE
+
+  TYPE(t) :: myobj
+
+  ! These are ok.
+  CALL myobj%sub (1)
+  WRITE (*,*) myobj%func (1)
+  WRITE (*,*) myobj%func (2.5)
+
+  ! These are not.
+  CALL myobj%sub (2.5) ! { dg-error "no matching specific binding" }
+  WRITE (*,*) myobj%func ("hello") ! { dg-error "no matching specific binding" }
+  CALL myobj%func (2.5) ! { dg-error "SUBROUTINE" }
+  WRITE (*,*) myobj%sub (1) ! { dg-error "FUNCTION" }
+
+END PROGRAM main
+
+! { dg-final { cleanup-modules "m" } }
Index: gcc/testsuite/gfortran.dg/typebound_generic_3.f03
===================================================================
--- gcc/testsuite/gfortran.dg/typebound_generic_3.f03	(revision 0)
+++ gcc/testsuite/gfortran.dg/typebound_generic_3.f03	(revision 0)
@@ -0,0 +1,65 @@
+! { dg-do run }
+
+! FIXME: Remove -w once switched to polymorphic passed-object dummy arguments.
+! { dg-options "-w" }
+
+! Type-bound procedures
+! Check calls with GENERIC bindings.
+
+MODULE m
+  IMPLICIT NONE
+
+  TYPE t
+  CONTAINS
+    PROCEDURE, NOPASS :: plain_int
+    PROCEDURE, NOPASS :: plain_real
+    PROCEDURE, PASS(me) :: passed_intint
+    PROCEDURE, PASS(me) :: passed_realreal
+
+    GENERIC :: gensub => plain_int, plain_real, passed_intint, passed_realreal
+  END TYPE t
+
+CONTAINS
+
+  SUBROUTINE plain_int (x)
+    IMPLICIT NONE
+    INTEGER :: x
+    WRITE (*,*) "Plain Integer"
+  END SUBROUTINE plain_int
+
+  SUBROUTINE plain_real (x)
+    IMPLICIT NONE
+    REAL :: x
+    WRITE (*,*) "Plain Real"
+  END SUBROUTINE plain_real
+
+  SUBROUTINE passed_intint (me, x, y)
+    IMPLICIT NONE
+    TYPE(t) :: me
+    INTEGER :: x, y
+    WRITE (*,*) "Passed Integer"
+  END SUBROUTINE passed_intint
+
+  SUBROUTINE passed_realreal (x, me, y)
+    IMPLICIT NONE
+    REAL :: x, y
+    TYPE(t) :: me
+    WRITE (*,*) "Passed Real"
+  END SUBROUTINE passed_realreal
+
+END MODULE m
+
+PROGRAM main
+  USE m
+  IMPLICIT NONE
+
+  TYPE(t) :: myobj
+
+  CALL myobj%gensub (5)
+  CALL myobj%gensub (2.5)
+  CALL myobj%gensub (5, 5)
+  CALL myobj%gensub (2.5, 2.5)
+END PROGRAM main
+
+! { dg-output "Plain Integer(\n|\r\n|\r).*Plain Real(\n|\r\n|\r).*Passed Integer(\n|\r\n|\r).*Passed Real" }
+! { dg-final { cleanup-modules "m" } }


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]