[Patch, fortran-dev] PR 42274: [fortran-dev Regression] ICE: segmentation fault

[Janus Weil <janus at gcc dot gnu dot org>]

Hi all,

here is my patch for PR 42274, which is the last regression of the
fortran-dev branch.

As you know, fortran-dev still contains Paul's new implementation of
dynamic dispatch (poylmorphic type-bound procedures), which internally
makes use of procedure pointer components to implement the polymorphic
calls.

Now, what my patch does is basically to add the 'ppc' attribute to all
the PPC members of the vtypes, which was not the case before, but is
needed since they are, in fact, PPCs. After setting these attributes,
there has been a bit of fallout (several regressions), which is what
the rest of the patch takes care of.

The patch has been regtested successfully on x86_64-unknown-linux-gnu.
The testcase is that from comment #16, which is more compact than the
original one. Ok for fortran-dev?

[Once this patch has landed on fortran-dev, we can (and should) merge
the branch back to trunk, since no further regressions (are known to)
exist.]

Cheers,
Janus


2010-04-26  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-26  Janus Weil  <janus@gcc.gnu.org>

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

Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c	(revision 158706)
+++ gcc/fortran/trans-expr.c	(working copy)
@@ -2486,7 +2486,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_exp
     not to the class declared type.  */
   vtab = gfc_find_derived_vtab (e->ts.u.derived, true);
   gcc_assert (vtab);
-  gfc_trans_assign_vtab_procs (&parmse->pre, 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));
@@ -5450,7 +5450,8 @@ 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 *vtab)
+void gfc_trans_assign_vtab_procs (stmtblock_t *block, gfc_symbol *dt,
+				  gfc_symbol *vtab)
 {
   gfc_component *cmp;
   tree vtb;
@@ -5485,8 +5486,10 @@ gfc_trans_assign (gfc_code * code)
   gfc_init_block (&body);
   for (; cmp; cmp = cmp->next)
     {
+      gfc_symbol *target = NULL;
+      
       /* Generic procedure - build its vtab.  */
-      if (cmp->ts.type == BT_DERIVED)
+      if (cmp->ts.type == BT_DERIVED && !cmp->tb)
 	{
 	  gfc_symbol *vt = cmp->ts.interface;
 
@@ -5502,7 +5505,7 @@ gfc_trans_assign (gfc_code * code)
 		continue;
 	    }
 
-	  gfc_trans_assign_vtab_procs (&body, vt);
+	  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);
@@ -5514,12 +5517,22 @@ gfc_trans_assign (gfc_code * code)
       /* 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))
+      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 (cmp->tb->u.specific->n.sym);
+      proc = gfc_get_symbol_decl (target);
       proc = gfc_build_addr_expr (TREE_TYPE (ctree), proc);
       gfc_add_modify (&body, ctree, proc);
     }
@@ -5576,7 +5589,7 @@ gfc_trans_class_assign (gfc_code *code)
 	  gfc_symtree *st;
 	  vtab = gfc_find_derived_vtab (code->expr2->ts.u.derived, true);
 	  gcc_assert (vtab);
-	  gfc_trans_assign_vtab_procs (&block, 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);
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 158706)
+++ gcc/fortran/symbol.c	(working copy)
@@ -4819,6 +4819,7 @@ add_proc_component (gfc_component *c, gfc_symbol *
   if (!c->tb)
     c->tb = XCNEW (gfc_typebound_proc);
   *c->tb = *st->n.tb;
+  c->tb->ppc = 1;
   c->attr.procedure = 1;
   c->attr.proc_pointer = 1;
   c->attr.flavor = FL_PROCEDURE;
@@ -4858,6 +4859,7 @@ add_proc_comps (gfc_component *c, gfc_symbol *vtyp
   else if (c->attr.proc_pointer && c->tb)
     {
       *c->tb = *st->n.tb;
+      c->tb->ppc = 1;
       c->ts.interface = st->n.tb->u.specific->n.sym;	  
     }
 }
@@ -4954,7 +4956,7 @@ copy_vtab_proc_comps (gfc_symbol *declared, gfc_sy
       c->attr.flavor = FL_PROCEDURE;
       c->attr.access = ACCESS_PRIVATE;
       c->attr.external = 1;
-      c->ts.interface = cmp->tb->u.specific->n.sym;
+      c->ts.interface = cmp->ts.interface;
       c->attr.untyped = 1;
       c->attr.if_source = IFSRC_IFBODY;
       c->initializer = gfc_get_expr ();
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c	(revision 158706)
+++ gcc/fortran/trans-stmt.c	(working copy)
@@ -4280,7 +4280,7 @@ gfc_trans_allocate (gfc_code * code)
 		{
 		  vtab = gfc_find_derived_vtab (ts->u.derived, true);
 		  gcc_assert (vtab);
-		  gfc_trans_assign_vtab_procs (&block, vtab);
+		  gfc_trans_assign_vtab_procs (&block, ts->u.derived, vtab);
 		  gfc_init_se (&lse, NULL);
 		  lse.want_pointer = 1;
 		  gfc_conv_expr (&lse, lhs);
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h	(revision 158706)
+++ gcc/fortran/trans.h	(working copy)
@@ -492,7 +492,7 @@ tree gfc_trans_assignment (gfc_expr *, gfc_expr *,
 tree gfc_trans_pointer_assignment (gfc_expr *, gfc_expr *);
 
 /* Generate code to assign typebound procedures to a derived vtab.  */
-void gfc_trans_assign_vtab_procs (stmtblock_t*, gfc_symbol*);
+void gfc_trans_assign_vtab_procs (stmtblock_t*, gfc_symbol*, gfc_symbol*);
 
 /* Initialize function decls for library functions.  */
 void gfc_build_intrinsic_lib_fndecls (void);

Attachment: class_15.f03
Description: Binary data