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.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152463 138bc75d-0d04-0410-961f-82ee72b054a4

6 files changed, 490 insertions, 11 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index a844ed655d5..24891ab3835 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,27 @@
+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
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index b40f01ba4bf..72f01264630 100644
--- a/gcc/fortran/gfortran.h
+++ b/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;
 
diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 1769eada5fe..2112d3e82b1 100644
--- a/gcc/fortran/module.c
+++ b/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
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index bb803b3475c..2f0972b04eb 100644
--- a/gcc/fortran/resolve.c
+++ b/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:
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 39285b16fea..8cd18db0a8f 100644
--- a/gcc/fortran/symbol.c
+++ b/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
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index eb741f8231f..77953c8e15f 100644
--- a/gcc/fortran/trans-expr.c
+++ b/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)