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

1 files changed, 124 insertions, 0 deletions

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)