trans-expr.c (select_class_proc): New function.

2009-10-05  Paul Thomas  <pault@gcc.gnu.org>

	* trans-expr.c (select_class_proc): New function.
	(conv_function_val): Deal with class methods and call above.
	* symbol.c (gfc_type_compatible): Treat case where both ts1 and
	ts2 are BT_CLASS.
	gfortran.h : Add structure gfc_class_esym_list and include in
	the structure gfc_expr.
	* module.c (load_derived_extensions): New function.
	(read_module): Call above.
	(write_dt_extensions): New function.
	(write_derived_extensions): New function.
	(write_module): Use the above.
	* resolve.c (resolve_typebound_call): Add a function expression
	for class methods.  This carries the chain of symbols for the
	dynamic dispatch in select_class_proc.
	(resolve_compcall): Add second, boolean argument to indicate if
	a function is being handled.
	(check_members): New function.
	(check_class_members): New function.
	(resolve_class_compcall): New function.
	(resolve_class_typebound_call): New function.
	(gfc_resolve_expr): Call above for component calls.. 

2009-10-05  Paul Thomas  <pault@gcc.gnu.org>

	* gfortran.dg/dynamic_dispatch_1.f90: New test.
	* gfortran.dg/dynamic_dispatch_2.f90: New test.
	* gfortran.dg/dynamic_dispatch_3.f90: New test.
	* gfortran.dg/module_md5_1.f90: Update md5 sum.

From-SVN: r152463

gcc/fortran/ChangeLog

+2009-10-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	* trans-expr.c (select_class_proc): New function.
+	(conv_function_val): Deal with class methods and call above.
+	* symbol.c (gfc_type_compatible): Treat case where both ts1 and
+	ts2 are BT_CLASS.
+	gfortran.h : Add structure gfc_class_esym_list and include in
+	the structure gfc_expr.
+	* module.c (load_derived_extensions): New function.
+	(read_module): Call above.
+	(write_dt_extensions): New function.
+	(write_derived_extensions): New function.
+	(write_module): Use the above.
+	* resolve.c (resolve_typebound_call): Add a function expression
+	for class methods.  This carries the chain of symbols for the
+	dynamic dispatch in select_class_proc.
+	(resolve_compcall): Add second, boolean argument to indicate if
+	a function is being handled.
+	(check_members): New function.
+	(check_class_members): New function.
+	(resolve_class_compcall): New function.
+	(resolve_class_typebound_call): New function.
+	(gfc_resolve_expr): Call above for component calls.. 
+
 2009-10-05  Daniel Kraft  <d@domob.eu>
 
 	PR fortran/41403

gcc/fortran/gfortran.h

@@ -1594,6 +1594,17 @@ typedef struct gfc_intrinsic_sym
 gfc_intrinsic_sym;
 
 
+typedef struct gfc_class_esym_list
+{
+  gfc_symbol *derived;
+  gfc_symbol *esym;
+  gfc_symbol *class_object;
+  struct gfc_class_esym_list *next;
+}
+gfc_class_esym_list;
+
+#define gfc_get_class_esym_list() XCNEW (gfc_class_esym_list)
+
 /* Expression nodes.  The expression node types deserve explanations,
    since the last couple can be easily misconstrued:
 
@@ -1705,6 +1716,7 @@ typedef struct gfc_expr
       const char *name;	/* Points to the ultimate name of the function */
       gfc_intrinsic_sym *isym;
       gfc_symbol *esym;
+      gfc_class_esym_list *class_esym;
     }
     function;
 

gcc/fortran/module.c

@@ -3972,6 +3972,61 @@ load_equiv (void)
 }
 
 
+/* This function loads the sym_root of f2k_derived with the extensions to
+   the derived type.  */
+static void
+load_derived_extensions (void)
+{
+  int symbol, nuse, j;
+  gfc_symbol *derived;
+  gfc_symbol *dt;
+  gfc_symtree *st;
+  pointer_info *info;
+  char name[GFC_MAX_SYMBOL_LEN + 1];
+  char module[GFC_MAX_SYMBOL_LEN + 1];
+  const char *p;
+
+  mio_lparen ();
+  while (peek_atom () != ATOM_RPAREN)
+    {
+      mio_lparen ();
+      mio_integer (&symbol);
+      info = get_integer (symbol);
+      derived = info->u.rsym.sym;
+
+      gcc_assert (derived->attr.flavor == FL_DERIVED);
+      if (derived->f2k_derived == NULL)
+	derived->f2k_derived = gfc_get_namespace (NULL, 0);
+
+      while (peek_atom () != ATOM_RPAREN)
+	{
+	  mio_lparen ();
+	  mio_internal_string (name);
+	  mio_internal_string (module);
+
+          /* Only use one use name to find the symbol.  */
+	  nuse = number_use_names (name, false);
+	  j = 1;
+	  p = find_use_name_n (name, &j, false);
+	  st = gfc_find_symtree (gfc_current_ns->sym_root, p);
+	  dt = st->n.sym;
+	  st = gfc_find_symtree (derived->f2k_derived->sym_root, name);
+	  if (st == NULL)
+	    {
+	      /* Only use the real name in f2k_derived to ensure a single
+		 symtree.  */
+	      st = gfc_new_symtree (&derived->f2k_derived->sym_root, name);
+	      st->n.sym = dt;
+	      st->n.sym->refs++;
+	    }
+	  mio_rparen ();
+	}
+      mio_rparen ();
+    }
+  mio_rparen ();
+}
+
+
 /* Recursive function to traverse the pointer_info tree and load a
    needed symbol.  We return nonzero if we load a symbol and stop the
    traversal, because the act of loading can alter the tree.  */
@@ -4113,7 +4168,7 @@ check_for_ambiguous (gfc_symbol *st_sym, pointer_info *info)
 static void
 read_module (void)
 {
-  module_locus operator_interfaces, user_operators;
+  module_locus operator_interfaces, user_operators, extensions;
   const char *p;
   char name[GFC_MAX_SYMBOL_LEN + 1];
   int i;
@@ -4130,10 +4185,13 @@ read_module (void)
   skip_list ();
   skip_list ();
 
-  /* Skip commons and equivalences for now.  */
+  /* Skip commons, equivalences and derived type extensions for now.  */
   skip_list ();
   skip_list ();
 
+  get_module_locus (&extensions);
+  skip_list ();
+
   mio_lparen ();
 
   /* Create the fixup nodes for all the symbols.  */
@@ -4386,6 +4444,11 @@ read_module (void)
 
   gfc_check_interfaces (gfc_current_ns);
 
+  /* Now we should be in a position to fill f2k_derived with derived type
+     extensions, since everything has been loaded.  */
+  set_module_locus (&extensions);
+  load_derived_extensions ();
+
   /* Clean up symbol nodes that were never loaded, create references
      to hidden symbols.  */
 
@@ -4594,6 +4657,36 @@ write_equiv (void)
 }
 
 
+/* Write derived type extensions to the module.  */
+
+static void
+write_dt_extensions (gfc_symtree *st)
+{
+  mio_lparen ();
+  mio_pool_string (&st->n.sym->name);
+  if (st->n.sym->module != NULL)
+    mio_pool_string (&st->n.sym->module);
+  else
+    mio_internal_string (module_name);
+  mio_rparen ();
+}
+
+static void
+write_derived_extensions (gfc_symtree *st)
+{
+  if (!((st->n.sym->attr.flavor == FL_DERIVED)
+	  && (st->n.sym->f2k_derived != NULL)
+	  && (st->n.sym->f2k_derived->sym_root != NULL)))
+    return;
+
+  mio_lparen ();
+  mio_symbol_ref (&(st->n.sym));
+  gfc_traverse_symtree (st->n.sym->f2k_derived->sym_root,
+			write_dt_extensions);
+  mio_rparen ();
+}
+
+
 /* Write a symbol to the module.  */
 
 static void
@@ -4820,6 +4913,13 @@ write_module (void)
   write_char ('\n');
   write_char ('\n');
 
+  mio_lparen ();
+  gfc_traverse_symtree (gfc_current_ns->sym_root,
+			write_derived_extensions);
+  mio_rparen ();
+  write_char ('\n');
+  write_char ('\n');
+
   /* Write symbol information.  First we traverse all symbols in the
      primary namespace, writing those that need to be written.
      Sometimes writing one symbol will cause another to need to be

gcc/fortran/resolve.c

@@ -4997,28 +4997,42 @@ resolve_typebound_call (gfc_code* c)
   c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL);
 
   gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual);
+
   gfc_free_expr (c->expr1);
-  c->expr1 = NULL;
+  c->expr1 = gfc_get_expr ();
+  c->expr1->expr_type = EXPR_FUNCTION;
+  c->expr1->symtree = target;
+  c->expr1->where = c->loc;
 
   return resolve_call (c);
 }
 
 
-/* Resolve a component-call expression.  */
-
+/* Resolve a component-call expression.  This originally was intended
+   only to see functions.  However, it is convenient to use it in 
+   resolving subroutine class methods, since we do not have to add a
+   gfc_code each time. */
 static gfc_try
-resolve_compcall (gfc_expr* e)
+resolve_compcall (gfc_expr* e, bool fcn)
 {
   gfc_actual_arglist* newactual;
   gfc_symtree* target;
 
   /* Check that's really a FUNCTION.  */
-  if (!e->value.compcall.tbp->function)
+  if (fcn && !e->value.compcall.tbp->function)
     {
       gfc_error ("'%s' at %L should be a FUNCTION",
 		 e->value.compcall.name, &e->where);
       return FAILURE;
     }
+  else if (!fcn && !e->value.compcall.tbp->subroutine)
+    {
+      /* To resolve class member calls, we borrow this bit
+         of code to select the specific procedures.  */
+      gfc_error ("'%s' at %L should be a SUBROUTINE",
+		 e->value.compcall.name, &e->where);
+      return FAILURE;
+    }
 
   /* These must not be assign-calls!  */
   gcc_assert (!e->value.compcall.assign);
@@ -5043,12 +5057,207 @@ resolve_compcall (gfc_expr* e)
   e->value.function.actual = newactual;
   e->value.function.name = e->value.compcall.name;
   e->value.function.esym = target->n.sym;
+  e->value.function.class_esym = NULL;
   e->value.function.isym = NULL;
   e->symtree = target;
   e->ts = target->n.sym->ts;
   e->expr_type = EXPR_FUNCTION;
 
-  return gfc_resolve_expr (e);
+  /* Resolution is not necessary if this is a class subroutine; this
+     function only has to identify the specific proc. Resolution of
+     the call will be done next in resolve_typebound_call.  */
+  return fcn ? gfc_resolve_expr (e) : SUCCESS;
+}
+
+
+/* Resolve a typebound call for the members in a class.  This group of
+   functions implements dynamic dispatch in the provisional version
+   of f03 OOP.  As soon as vtables are in place and contain pointers
+   to methods, this will no longer be necessary.  */
+static gfc_expr *list_e;
+static void check_class_members (gfc_symbol *);
+static gfc_try class_try;
+static bool fcn_flag;
+static gfc_symbol *class_object;
+
+
+static void
+check_members (gfc_symbol *derived)
+{
+  if (derived->attr.flavor == FL_DERIVED)
+    check_class_members (derived);
+}
+
+
+static void 
+check_class_members (gfc_symbol *derived)
+{
+  gfc_symbol* tbp_sym;
+  gfc_expr *e;
+  gfc_symtree *tbp;
+  gfc_class_esym_list *etmp;
+
+  e = gfc_copy_expr (list_e);
+
+  tbp = gfc_find_typebound_proc (derived, &class_try,
+				 e->value.compcall.name,
+				 false, &e->where);
+
+  if (tbp == NULL)
+    {
+      gfc_error ("no typebound available procedure named '%s' at %L",
+		 e->value.compcall.name, &e->where);
+      return;
+    }
+
+  if (tbp->n.tb->is_generic)
+    {
+      tbp_sym = NULL;
+
+      /* If we have to match a passed class member, force the actual
+	 expression to have the correct type.  */
+      if (!tbp->n.tb->nopass)
+	{
+	  if (e->value.compcall.base_object == NULL)
+	    e->value.compcall.base_object =
+			extract_compcall_passed_object (e);
+
+          e->value.compcall.base_object->ts.type = BT_DERIVED;
+          e->value.compcall.base_object->ts.u.derived = derived;
+	}
+    }
+  else
+    tbp_sym = tbp->n.tb->u.specific->n.sym;
+
+  e->value.compcall.tbp = tbp->n.tb;
+  e->value.compcall.name = tbp->name;
+
+  /* Do the renaming, PASSing, generic => specific and other
+     good things for each class member.  */
+  class_try = (resolve_compcall (e, fcn_flag) == SUCCESS)
+				? class_try : FAILURE;
+
+  /* Now transfer the found symbol to the esym list.  */
+  if (class_try == SUCCESS)
+    {
+      etmp = list_e->value.function.class_esym;
+      list_e->value.function.class_esym
+		= gfc_get_class_esym_list();
+      list_e->value.function.class_esym->next = etmp;
+      list_e->value.function.class_esym->derived = derived;
+      list_e->value.function.class_esym->class_object
+		= class_object;
+      list_e->value.function.class_esym->esym
+		= e->value.function.esym;
+    }
+
+  gfc_free_expr (e);
+  
+  /* Burrow down into grandchildren types.  */
+  if (derived->f2k_derived)
+    gfc_traverse_ns (derived->f2k_derived, check_members);
+}
+
+
+/* Eliminate esym_lists where all the members point to the
+   typebound procedure of the declared type; ie. one where
+   type selection has no effect..  */
+static void
+resolve_class_esym (gfc_expr *e)
+{
+  gfc_class_esym_list *p, *q;
+  bool empty = true;
+
+  gcc_assert (e && e->expr_type == EXPR_FUNCTION);
+
+  p = e->value.function.class_esym;
+  if (p == NULL)
+    return;
+
+  for (; p; p = p->next)
+    empty = empty && (e->value.function.esym == p->esym);
+
+  if (empty)
+    {
+      p = e->value.function.class_esym;
+      for (; p; p = q)
+	{
+	  q = p->next;
+	  gfc_free (p);
+	}
+      e->value.function.class_esym = NULL;
+   }
+}
+
+
+/* Resolve a CLASS typebound function, or 'method'.  */
+static gfc_try
+resolve_class_compcall (gfc_expr* e)
+{
+  gfc_symbol *derived;
+
+  class_object = e->symtree->n.sym;
+
+  /* Get the CLASS type.  */
+  derived = e->symtree->n.sym->ts.u.derived;
+
+  /* Get the data component, which is of the declared type.  */
+  derived = derived->components->ts.u.derived;
+
+  /* Resolve the function call for each member of the class.  */
+  class_try = SUCCESS;
+  fcn_flag = true;
+  list_e = gfc_copy_expr (e);
+  check_class_members (derived);
+
+  class_try = (resolve_compcall (e, true) == SUCCESS)
+		 ? class_try : FAILURE;
+
+  /* Transfer the class list to the original expression.  Note that
+     the class_esym list is cleaned up in trans-expr.c, as the calls
+     are translated.  */
+  e->value.function.class_esym = list_e->value.function.class_esym;
+  list_e->value.function.class_esym = NULL;
+  gfc_free_expr (list_e);
+
+  resolve_class_esym (e);
+
+  return class_try;
+}
+
+/* Resolve a CLASS typebound subroutine, or 'method'.  */
+static gfc_try
+resolve_class_typebound_call (gfc_code *code)
+{
+  gfc_symbol *derived;
+
+  class_object = code->expr1->symtree->n.sym;
+
+  /* Get the CLASS type.  */
+  derived = code->expr1->symtree->n.sym->ts.u.derived;
+
+  /* Get the data component, which is of the declared type.  */
+  derived = derived->components->ts.u.derived;
+
+  class_try = SUCCESS;
+  fcn_flag = false;
+  list_e = gfc_copy_expr (code->expr1);
+  check_class_members (derived);
+
+  class_try = (resolve_typebound_call (code) == SUCCESS)
+		 ? class_try : FAILURE;
+
+  /* Transfer the class list to the original expression.  Note that
+     the class_esym list is cleaned up in trans-expr.c, as the calls
+     are translated.  */
+  code->expr1->value.function.class_esym
+			= list_e->value.function.class_esym;
+  list_e->value.function.class_esym = NULL;
+  gfc_free_expr (list_e);
+
+  resolve_class_esym (code->expr1);
+
+  return class_try;
 }
 
 
@@ -5162,7 +5371,10 @@ gfc_resolve_expr (gfc_expr *e)
       break;
 
     case EXPR_COMPCALL:
-      t = resolve_compcall (e);
+      if (e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
+	t = resolve_class_compcall (e);
+      else
+	t = resolve_compcall (e, true);
       break;
 
     case EXPR_SUBSTRING:
@@ -7517,7 +7729,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 
 	case EXEC_COMPCALL:
 	compcall:
-	  resolve_typebound_call (code);
+	  if (code->expr1->symtree
+		&& code->expr1->symtree->n.sym->ts.type == BT_CLASS)
+	    resolve_class_typebound_call (code);
+	  else
+	    resolve_typebound_call (code);
 	  break;
 
 	case EXEC_CALL_PPC:

gcc/fortran/symbol.c

@@ -4579,9 +4579,12 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
   if ((ts1->type == BT_DERIVED || ts1->type == BT_CLASS)
       && (ts2->type == BT_DERIVED || ts2->type == BT_CLASS))
     {
-      if (ts1->type == BT_CLASS)
+      if (ts1->type == BT_CLASS && ts2->type == BT_DERIVED)
 	return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
 					 ts2->u.derived);
+      else if (ts1->type == BT_CLASS && ts2->type == BT_CLASS)
+	return gfc_type_is_extension_of (ts1->u.derived->components->ts.u.derived,
+					 ts2->u.derived->components->ts.u.derived);
       else if (ts2->type != BT_CLASS)
 	return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
       else

gcc/fortran/trans-expr.c

@@ -1523,11 +1523,135 @@ get_proc_ptr_comp (gfc_expr *e)
 }
 
 
+/* Select a class typebound procedure at runtime.  */
+static void
+select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
+		   tree declared, locus *where)
+{
+  tree end_label;
+  tree label;
+  tree tmp;
+  tree vindex;
+  stmtblock_t body;
+  gfc_class_esym_list *next_elist, *tmp_elist;
+
+  /* Calculate the switch expression: class_object.vindex.  */
+  gcc_assert (elist->class_object->ts.type == BT_CLASS);
+  tmp = elist->class_object->ts.u.derived->components->next->backend_decl;
+  vindex = fold_build3 (COMPONENT_REF, TREE_TYPE (tmp),
+			elist->class_object->backend_decl,
+			tmp, NULL_TREE);
+  vindex = gfc_evaluate_now (vindex, &se->pre);
+
+  /* Fix the function type to be that of the declared type.  */
+  declared = gfc_create_var (TREE_TYPE (declared), "method");
+
+  end_label = gfc_build_label_decl (NULL_TREE);
+
+  gfc_init_block (&body);
+
+  /* Go through the list of extensions.  */
+  for (; elist; elist = next_elist)
+    {
+      /* This case has already been added.  */
+      if (elist->derived == NULL)
+	goto free_elist;
+
+      /* Run through the chain picking up all the cases that call the
+	 same procedure.  */
+      tmp_elist = elist;
+      for (; elist; elist = elist->next)
+	{
+	  tree cval;
+
+	  if (elist->esym != tmp_elist->esym)
+	    continue;
+
+	  cval = build_int_cst (TREE_TYPE (vindex),
+				elist->derived->vindex);
+	  /* Build a label for the vindex value.  */
+	  label = gfc_build_label_decl (NULL_TREE);
+	  tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
+			     cval, NULL_TREE, label);
+	  gfc_add_expr_to_block (&body, tmp);
+
+	  /* Null the reference the derived type so that this case is
+	     not used again.  */
+	  elist->derived = NULL;
+	}
+
+      elist = tmp_elist;
+
+      /* Get a pointer to the procedure,  */
+      tmp = gfc_get_symbol_decl (elist->esym);
+      if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+	{
+	  gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
+	  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+	}
+
+      /* Assign the pointer to the appropriate procedure.  */
+      gfc_add_modify (&body, declared,
+		      fold_convert (TREE_TYPE (declared), tmp));
+
+      /* Break to the end of the construct.  */
+      tmp = build1_v (GOTO_EXPR, end_label);
+      gfc_add_expr_to_block (&body, tmp);
+
+      /* Free the elists as we go; freeing them in gfc_free_expr causes
+	 segfaults because it occurs too early and too often.  */
+    free_elist:
+      next_elist = elist->next;
+      gfc_free (elist);
+      elist = NULL;
+    }
+
+  /* Default is an error.  */
+  label = gfc_build_label_decl (NULL_TREE);
+  tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
+		     NULL_TREE, NULL_TREE, label);
+  gfc_add_expr_to_block (&body, tmp);
+  tmp = gfc_trans_runtime_error (true, where,
+		"internal error: bad vindex in dynamic dispatch");
+  gfc_add_expr_to_block (&body, tmp);
+
+  /* Write the switch expression.  */
+  tmp = gfc_finish_block (&body);
+  tmp = build3_v (SWITCH_EXPR, vindex, tmp, NULL_TREE);
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  tmp = build1_v (LABEL_EXPR, end_label);
+  gfc_add_expr_to_block (&se->pre, tmp);
+
+  se->expr = declared;
+  return;
+}
+
+
 static void
 conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
 {
   tree tmp;
 
+  if (expr && expr->symtree
+	&& expr->value.function.class_esym)
+    {
+      if (!sym->backend_decl)
+	sym->backend_decl = gfc_get_extern_function_decl (sym);
+
+      tmp = sym->backend_decl;
+
+      if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+	{
+	  gcc_assert (TREE_CODE (tmp) == FUNCTION_DECL);
+	  tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+	}
+
+      select_class_proc (se, expr->value.function.class_esym,
+			 tmp, &expr->where);
+      return;
+    }
+
   if (gfc_is_proc_ptr_comp (expr, NULL))
     tmp = get_proc_ptr_comp (expr);
   else if (sym->attr.dummy)

gcc/testsuite/ChangeLog

+2009-10-05  Paul Thomas  <pault@gcc.gnu.org>
+
+	* gfortran.dg/dynamic_dispatch_1.f90: New test.
+	* gfortran.dg/dynamic_dispatch_2.f90: New test.
+	* gfortran.dg/dynamic_dispatch_3.f90: New test.
+	* gfortran.dg/module_md5_1.f90: Update md5 sum.
+
 2009-10-05  Sriraman Tallam  <tmsriram@google.com>
 
 	* gcc.dg/plugin/selfassign.c (plugin_init): Change plugin_pass to

gcc/testsuite/gfortran.dg/dynamic_dispatch_1.f03

+! { dg-do run }
+! Tests dynamic dispatch of class functions.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+module m
+  type :: t1
+    integer :: i = 42
+    procedure(make_real), pointer :: ptr
+  contains
+    procedure, pass :: real => make_real
+    procedure, pass :: make_integer
+    procedure, pass :: prod => i_m_j
+    generic, public :: extract => real, make_integer
+    generic, public :: base_extract => real, make_integer
+  end type t1
+
+  type, extends(t1) :: t2
+    integer :: j = 99
+  contains
+    procedure, pass :: real => make_real2
+    procedure, pass :: make_integer_2
+    procedure, pass :: prod => i_m_j_2
+    generic, public :: extract => real, make_integer_2
+  end type t2
+contains
+  real function make_real (arg)
+    class(t1), intent(in) :: arg
+    make_real = real (arg%i)
+  end function make_real
+
+  real function make_real2 (arg)
+    class(t2), intent(in) :: arg
+    make_real2 = real (arg%j)
+  end function make_real2
+
+  integer function make_integer (arg, arg2)
+    class(t1), intent(in) :: arg
+    integer :: arg2
+    make_integer = arg%i * arg2
+  end function make_integer
+
+  integer function make_integer_2 (arg, arg2)
+    class(t2), intent(in) :: arg
+    integer :: arg2
+    make_integer_2 = arg%j * arg2
+  end function make_integer_2
+
+  integer function i_m_j (arg)
+    class(t1), intent(in) :: arg
+        i_m_j = arg%i
+  end function i_m_j
+
+  integer function i_m_j_2 (arg)
+    class(t2), intent(in) :: arg
+        i_m_j_2 = arg%j
+  end function i_m_j_2
+end module m
+
+  use m
+  type, extends(t1) :: l1
+    character(16) :: chr
+  end type l1
+  class(t1), pointer :: a !=> NULL()
+  type(t1), target :: b
+  type(t2), target :: c
+  type(l1), target :: d
+  a => b                                   ! declared type
+  if (a%real() .ne. real (42)) call abort
+  if (a%prod() .ne. 42) call abort
+  if (a%extract (2) .ne. 84) call abort
+  if (a%base_extract (2) .ne. 84) call abort
+  a => c                                   ! extension in module
+  if (a%real() .ne. real (99)) call abort
+  if (a%prod() .ne. 99) call abort
+  if (a%extract (3) .ne. 297) call abort
+  if (a%base_extract (3) .ne. 126) call abort
+  a => d                                   ! extension in main
+  if (a%real() .ne. real (42)) call abort
+  if (a%prod() .ne. 42) call abort
+  if (a%extract (4) .ne. 168) call abort
+  if (a%base_extract (4) .ne. 168) call abort
+end
+! { dg-final { cleanup-modules "m" } }

gcc/testsuite/gfortran.dg/dynamic_dispatch_2.f03

+! { dg-do run }
+! Tests dynamic dispatch of class subroutines.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+module m
+  type :: t1
+    integer :: i = 42
+    procedure(make_real), pointer :: ptr
+  contains
+    procedure, pass :: real => make_real
+    procedure, pass :: make_integer
+    procedure, pass :: prod => i_m_j
+    generic, public :: extract => real, make_integer
+    generic, public :: base_extract => real, make_integer
+  end type t1
+
+  type, extends(t1) :: t2
+    integer :: j = 99
+  contains
+    procedure, pass :: real => make_real2
+    procedure, pass :: make_integer_2
+    procedure, pass :: prod => i_m_j_2
+    generic, public :: extract => real, make_integer_2
+  end type t2
+contains
+  subroutine make_real (arg, arg2)
+    class(t1), intent(in) :: arg
+    real :: arg2
+    arg2 = real (arg%i)
+  end subroutine make_real
+
+  subroutine make_real2 (arg, arg2)
+    class(t2), intent(in) :: arg
+    real :: arg2
+    arg2 = real (arg%j)
+  end subroutine make_real2
+
+  subroutine make_integer (arg, arg2, arg3)
+    class(t1), intent(in) :: arg
+    integer :: arg2, arg3
+    arg3 = arg%i * arg2
+  end subroutine make_integer
+
+  subroutine make_integer_2 (arg, arg2, arg3)
+    class(t2), intent(in) :: arg
+    integer :: arg2, arg3
+    arg3 = arg%j * arg2
+  end subroutine make_integer_2
+
+  subroutine i_m_j (arg, arg2)
+    class(t1), intent(in) :: arg
+    integer :: arg2
+        arg2 = arg%i
+  end subroutine i_m_j
+
+  subroutine i_m_j_2 (arg, arg2)
+    class(t2), intent(in) :: arg
+    integer :: arg2
+        arg2 = arg%j
+  end subroutine i_m_j_2
+end module m
+
+  use m
+  type, extends(t1) :: l1
+    character(16) :: chr
+  end type l1
+  class(t1), pointer :: a !=> NULL()
+  type(t1), target :: b
+  type(t2), target :: c
+  type(l1), target :: d
+  real :: r
+  integer :: i
+
+  a => b                                   ! declared type
+  call a%real(r)
+  if (r .ne. real (42)) call abort
+  call a%prod(i)
+  if (i .ne. 42) call abort
+  call a%extract (2, i)
+  if (i .ne. 84) call abort
+  call a%base_extract (2, i)
+  if (i .ne. 84) call abort
+
+  a => c                                   ! extension in module
+  call a%real(r)
+  if (r .ne. real (99)) call abort
+  call a%prod(i)
+  if (i .ne. 99) call abort
+  call a%extract (3, i)
+  if (i .ne. 297) call abort
+  call a%base_extract (3, i)
+  if (i .ne. 126) call abort
+
+  a => d                                   ! extension in main
+  call a%real(r)
+  if (r .ne. real (42)) call abort
+  call a%prod(i)
+  if (i .ne. 42) call abort
+  call a%extract (4, i)
+  if (i .ne. 168) call abort
+  call a%extract (4, i)
+  if (i .ne. 168) call abort
+end
+! { dg-final { cleanup-modules "m" } }

gcc/testsuite/gfortran.dg/dynamic_dispatch_3.f03

+! { dg-do run }
+! Tests dynamic dispatch of class functions, spread over
+! different modules. Apart from the location of the derived
+! type declarations, this test is the same as
+! dynamic_dispatch_1.f03
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+module m1
+  type :: t1
+    integer :: i = 42
+    procedure(make_real), pointer :: ptr
+  contains
+    procedure, pass :: real => make_real
+    procedure, pass :: make_integer
+    procedure, pass :: prod => i_m_j
+    generic, public :: extract => real, make_integer
+    generic, public :: base_extract => real, make_integer
+  end type t1
+contains
+  real function make_real (arg)
+    class(t1), intent(in) :: arg
+    make_real = real (arg%i)
+  end function make_real
+
+  integer function make_integer (arg, arg2)
+    class(t1), intent(in) :: arg
+    integer :: arg2
+    make_integer = arg%i * arg2
+  end function make_integer
+
+  integer function i_m_j (arg)
+    class(t1), intent(in) :: arg
+        i_m_j = arg%i
+  end function i_m_j
+end module m1
+
+module m2
+  use m1
+  type, extends(t1) :: t2
+    integer :: j = 99
+  contains
+    procedure, pass :: real => make_real2
+    procedure, pass :: make_integer_2
+    procedure, pass :: prod => i_m_j_2
+    generic, public :: extract => real, make_integer_2
+  end type t2
+contains
+  real function make_real2 (arg)
+    class(t2), intent(in) :: arg
+    make_real2 = real (arg%j)
+  end function make_real2
+
+  integer function make_integer_2 (arg, arg2)
+    class(t2), intent(in) :: arg
+    integer :: arg2
+    make_integer_2 = arg%j * arg2
+  end function make_integer_2
+
+  integer function i_m_j_2 (arg)
+    class(t2), intent(in) :: arg
+        i_m_j_2 = arg%j
+  end function i_m_j_2
+end module m2
+
+  use m1
+  use m2
+  type, extends(t1) :: l1
+    character(16) :: chr
+  end type l1
+  class(t1), pointer :: a !=> NULL()
+  type(t1), target :: b
+  type(t2), target :: c
+  type(l1), target :: d
+  a => b                                   ! declared type in module m1
+  if (a%real() .ne. real (42)) call abort
+  if (a%prod() .ne. 42) call abort
+  if (a%extract (2) .ne. 84) call abort
+  if (a%base_extract (2) .ne. 84) call abort
+  a => c                                   ! extension in module m2
+  if (a%real() .ne. real (99)) call abort
+  if (a%prod() .ne. 99) call abort
+  if (a%extract (3) .ne. 297) call abort
+  if (a%base_extract (3) .ne. 126) call abort
+  a => d                                   ! extension in main
+  if (a%real() .ne. real (42)) call abort
+  if (a%prod() .ne. 42) call abort
+  if (a%extract (4) .ne. 168) call abort
+  if (a%base_extract (4) .ne. 168) call abort
+end
+! { dg-final { cleanup-modules "m1, m2" } }

gcc/testsuite/gfortran.dg/module_md5_1.f90

@@ -10,5 +10,5 @@ program test
   use foo
   print *, pi
 end program test
-! { dg-final { scan-module "foo" "MD5:dc2fd1358dcaddc25e3c89dae859ef32" } }
+! { dg-final { scan-module "foo" "MD5:9c43cf4d713824ec6894b83250720e68" } }
 ! { dg-final { cleanup-modules "foo" } }