[multiple changes]

2010-04-29  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/43896
	* symbol.c (add_proc_component,copy_vtab_proc_comps): Remove
	initializers for PPC members of the vtabs.

2010-04-29  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42274
	* symbol.c (add_proc_component,add_proc_comps): Correctly set the 'ppc'
	attribute for all PPC members of the vtypes.
	(copy_vtab_proc_comps): Copy the correct interface.
	* trans.h (gfc_trans_assign_vtab_procs): Modified prototype.
	* trans-expr.c (gfc_trans_assign_vtab_procs): Pass the derived type as
	a dummy argument and make sure all PPC members of the vtab are
	initialized correctly.
	(gfc_conv_derived_to_class,gfc_trans_class_assign): Additional argument
	in call to gfc_trans_assign_vtab_procs.
	* trans-stmt.c (gfc_trans_allocate): Ditto.

2010-04-29  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/43326
	* resolve.c (resolve_typebound_function): Renamed
	resolve_class_compcall.Do all the detection of class references
	here.
	(resolve_typebound_subroutine): resolve_class_typebound_call
	renamed. Otherwise same as resolve_typebound_function.
	(gfc_resolve_expr): Call resolve_typebound_function.
	(resolve_code): Call resolve_typebound_subroutine.

2010-04-29  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/43492
	* resolve.c (resolve_typebound_generic_call): For CLASS methods
	pass back the specific symtree name, rather than the target
	name.

2010-04-29  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/42353
	* resolve.c (resolve_structure_cons): Make the initializer of
	the vtab component 'extends' the same type as the component.

2010-04-29  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/42680
	* interface.c (check_interface1): Pass symbol name rather than NULL to
	gfc_compare_interfaces.(gfc_compare_interfaces): Add assert to
	trap MULL. (gfc_compare_derived_types): Revert previous change
	incorporated incorrectly during merge from trunk, r155778.
	* resolve.c (check_generic_tbp_ambiguity): Pass symbol name rather
	than NULL to gfc_compare_interfaces.
	* symbol.c (add_generic_specifics): Likewise.

2010-02-29  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42353
	* interface.c (gfc_compare_derived_types): Add condition for vtype.
	* symbol.c (gfc_find_derived_vtab): Sey access to private.
	(gfc_find_derived_vtab): Likewise.
	* module.c (ab_attribute): Add enumerator AB_VTAB.
	(mio_symbol_attribute): Use new attribute, AB_VTAB.
	(check_for_ambiguous): Likewise.

2010-04-29  Paul Thomas  <pault@gcc.gnu.org>
	    Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41829
	* trans-expr.c (select_class_proc): Remove function.
	(conv_function_val): Delete reference to previous.
	(gfc_conv_derived_to_class): Add second argument to the call to
	gfc_find_derived_vtab.
	(gfc_conv_structure): Exclude proc_pointer components when
	accessing $data field of class objects.
	(gfc_trans_assign_vtab_procs): New function.
	(gfc_trans_class_assign): Add second argument to the call to
	gfc_find_derived_vtab.
	* symbol.c (gfc_build_class_symbol): Add delayed_vtab arg and
	implement holding off searching for the vptr derived type.
	(add_proc_component): New function.
	(add_proc_comps): New function.
	(add_procs_to_declared_vtab1): New function.
	(copy_vtab_proc_comps): New function.
	(add_procs_to_declared_vtab): New function.
	(void add_generic_specifics): New function.
	(add_generics_to_declared_vtab): New function.
	(gfc_find_derived_vtab): Add second argument to the call to
	gfc_find_derived_vtab. Add the calls to
	add_procs_to_declared_vtab and add_generics_to_declared_vtab.
	* decl.c (build_sym, build_struct): Use new arg in calls to
	gfc_build_class_symbol.
	* gfortran.h : Add vtype bitfield to symbol_attr. Remove the
	definition of struct gfc_class_esym_list. Modify prototypes
	of gfc_build_class_symbol and gfc_find_derived_vtab.
	* trans-stmt.c (gfc_trans_allocate): Add second argument to the
	call to gfc_find_derived_vtab.
	* module.c : Add the vtype attribute.
	* trans.h : Add prototype for gfc_trans_assign_vtab_procs.
	* resolve.c (resolve_typebound_generic_call): Add second arg
	to pass along the generic name for class methods.
	(resolve_typebound_call): The same.
	(resolve_compcall): Use the second arg to carry the generic
	name from the above. Remove the reference to class_esym.
	(check_members, check_class_members, resolve_class_esym,
	hash_value_expr): Remove functions.
	(resolve_class_compcall, resolve_class_typebound_call): Modify
	to use vtable rather than member by member calls.
	(gfc_resolve_expr): Modify second arg in call to
	resolve_compcall.
	(resolve_select_type): Add second arg in call to
	gfc_find_derived_vtab.
	(resolve_code): Add second arg in call resolve_typebound_call.
	(resolve_fl_derived): Exclude vtypes from check for late
	procedure definitions. Likewise for checking of explicit
	interface and checking of pass arg.
	* iresolve.c (gfc_resolve_extends_type_of): Add second arg in
	calls to gfc_find_derived_vtab.
	* match.c (select_type_set_tmp): Use new arg in call to
	gfc_build_class_symbol.
	* trans-decl.c (gfc_get_symbol_decl): Complete vtable if
	necessary.
	* parse.c (endType): Finish incomplete classes.


2010-04-29  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42274
	* gfortran.dg/class_16.f03: New test.

2010-04-29  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/42274
	* gfortran.dg/class_15.f03: New.

2010-04-29  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/43326
	* gfortran.dg/dynamic_dispatch_9.f03: New test.

2010-04-29  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/43492
	* gfortran.dg/generic_22.f03 : New test.

2010-04-29  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/42353
	* gfortran.dg/class_14.f03: New test.

2010-04-29  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/42680
	* gfortran.dg/interface_32.f90: New test.

2009-04-29  Paul Thomas  <pault@gcc.gnu.org>
	    Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41829
	* gfortran.dg/dynamic_dispatch_5.f03 : Change to "run".
	* gfortran.dg/dynamic_dispatch_7.f03 : New test.
	* gfortran.dg/dynamic_dispatch_8.f03 : New test.

From-SVN: r158910

1 files changed, 105 insertions, 136 deletions

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index dc138a3..dfd38cc 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -1532,141 +1532,11 @@ 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, gfc_expr *expr)
-{
-  tree end_label;
-  tree label;
-  tree tmp;
-  tree hash;
-  stmtblock_t body;
-  gfc_class_esym_list *next_elist, *tmp_elist;
-  gfc_se tmpse;
-
-  /* Convert the hash expression.  */
-  gfc_init_se (&tmpse, NULL);
-  gfc_conv_expr (&tmpse, elist->hash_value);
-  gfc_add_block_to_block (&se->pre, &tmpse.pre);
-  hash = gfc_evaluate_now (tmpse.expr, &se->pre);
-  gfc_add_block_to_block (&se->post, &tmpse.post);
-
-  /* Fix the function type to be that of the declared type method.  */
-  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;
-
-      /* Skip abstract base types.  */
-      if (elist->derived->attr.abstract)
-       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 (hash),
-				elist->derived->hash_value);
-	  /* Build a label for the hash 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;
-      if (elist->hash_value)
-	gfc_free_expr (elist->hash_value);
-      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, &expr->where,
-		"internal error: bad hash value in dynamic dispatch");
-  gfc_add_expr_to_block (&body, tmp);
-
-  /* Write the switch expression.  */
-  tmp = gfc_finish_block (&body);
-  tmp = build3_v (SWITCH_EXPR, hash, 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);
-      return;
-    }
-
   if (gfc_is_proc_ptr_comp (expr, NULL))
     tmp = get_proc_ptr_comp (expr);
   else if (sym->attr.dummy)
@@ -2614,8 +2484,9 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
 
   /* Remember the vtab corresponds to the derived type
     not to the class declared type.  */
-  vtab = gfc_find_derived_vtab (e->ts.u.derived);
+  vtab = gfc_find_derived_vtab (e->ts.u.derived, true);
   gcc_assert (vtab);
+  gfc_trans_assign_vtab_procs (&parmse->pre, e->ts.u.derived, vtab);
   tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
   gfc_add_modify (&parmse->pre, ctree,
 		  fold_convert (TREE_TYPE (ctree), tmp));
@@ -4463,7 +4334,7 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
       if (!c->expr || cm->attr.allocatable)
         continue;
 
-      if (cm->ts.type == BT_CLASS)
+      if (cm->ts.type == BT_CLASS && !cm->attr.proc_pointer)
 	{
 	  gfc_component *data;
 	  data = gfc_find_component (cm->ts.u.derived, "$data", true, true);
@@ -4484,10 +4355,11 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, int init)
       else if (cm->initializer && cm->initializer->expr_type != EXPR_NULL
 	       && strcmp (cm->name, "$extends") == 0)
 	{
+	  tree vtab;
 	  gfc_symbol *vtabs;
 	  vtabs = cm->initializer->symtree->n.sym;
-	  val = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
-	  CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val);
+	  vtab = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtabs));
+	  CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, vtab);
 	}
       else
 	{
@@ -5579,6 +5451,103 @@ gfc_trans_assign (gfc_code * code)
 }
 
 
+/* Generate code to assign typebound procedures to a derived vtab.  */
+void gfc_trans_assign_vtab_procs (stmtblock_t *block, gfc_symbol *dt,
+				  gfc_symbol *vtab)
+{
+  gfc_component *cmp;
+  tree vtb;
+  tree ctree;
+  tree proc;
+  tree cond = NULL_TREE;
+  stmtblock_t body;
+  bool seen_extends;
+
+  /* Point to the first procedure pointer.  */
+  cmp = gfc_find_component (vtab->ts.u.derived, "$extends", true, true);
+
+  seen_extends = (cmp != NULL);
+
+  vtb = gfc_get_symbol_decl (vtab);
+
+  if (seen_extends)
+    {
+      cmp = cmp->next;
+      if (!cmp)
+	return;
+      ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+		           vtb, cmp->backend_decl, NULL_TREE);
+      cond = fold_build2 (EQ_EXPR, boolean_type_node, ctree,
+			   build_int_cst (TREE_TYPE (ctree), 0));
+    }
+  else
+    {
+      cmp = vtab->ts.u.derived->components; 
+    }
+
+  gfc_init_block (&body);
+  for (; cmp; cmp = cmp->next)
+    {
+      gfc_symbol *target = NULL;
+      
+      /* Generic procedure - build its vtab.  */
+      if (cmp->ts.type == BT_DERIVED && !cmp->tb)
+	{
+	  gfc_symbol *vt = cmp->ts.interface;
+
+	  if (vt == NULL)
+	    {
+	      /* Use association loses the interface.  Obtain the vtab
+		 by name instead.  */
+	      char name[2 * GFC_MAX_SYMBOL_LEN + 8];
+	      sprintf (name, "vtab$%s$%s", vtab->ts.u.derived->name,
+		       cmp->name);
+	      gfc_find_symbol (name, vtab->ns, 0, &vt);
+	      if (vt == NULL)
+		continue;
+	    }
+
+	  gfc_trans_assign_vtab_procs (&body, dt, vt);
+	  ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+			       vtb, cmp->backend_decl, NULL_TREE);
+	  proc = gfc_get_symbol_decl (vt);
+	  proc = gfc_build_addr_expr (TREE_TYPE (ctree), proc);
+	  gfc_add_modify (&body, ctree, proc);
+	  continue;
+	}
+
+      /* This is required when typebound generic procedures are called
+	 with derived type targets.  The specific procedures do not get
+	 added to the vtype, which remains "empty".  */
+      if (cmp->tb && cmp->tb->u.specific && cmp->tb->u.specific->n.sym)
+	target = cmp->tb->u.specific->n.sym;
+      else
+	{
+	  gfc_symtree *st;
+	  st = gfc_find_typebound_proc (dt, NULL, cmp->name, false, NULL);
+	  if (st->n.tb && st->n.tb->u.specific)
+	    target = st->n.tb->u.specific->n.sym;
+	}
+
+      if (!target)
+	continue;
+
+      ctree = fold_build3 (COMPONENT_REF, TREE_TYPE (cmp->backend_decl),
+			   vtb, cmp->backend_decl, NULL_TREE);
+      proc = gfc_get_symbol_decl (target);
+      proc = gfc_build_addr_expr (TREE_TYPE (ctree), proc);
+      gfc_add_modify (&body, ctree, proc);
+    }
+
+  proc = gfc_finish_block (&body);
+
+  if (seen_extends)
+    proc = build3_v (COND_EXPR, cond, proc, build_empty_stmt (input_location));
+
+  gfc_add_expr_to_block (block, proc);
+}
+
+
 /* Translate an assignment to a CLASS object
    (pointer or ordinary assignment).  */
 
@@ -5620,9 +5589,9 @@ gfc_trans_class_assign (gfc_code *code)
 	{
 	  gfc_symbol *vtab;
 	  gfc_symtree *st;
-	  vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived);
+	  vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived, true);
 	  gcc_assert (vtab);
-
+	  gfc_trans_assign_vtab_procs (&block, code->expr2->ts.u.derived, vtab);
 	  rhs = gfc_get_expr ();
 	  rhs->expr_type = EXPR_VARIABLE;
 	  gfc_find_sym_tree (vtab->name, NULL, 1, &st);