diff mbox

[Fortran,OOP] PR 63552: Type-bound procedures rejected as actual argument to dummy procedure

Message ID CAKwh3qhqBmu+VBBF_wcc8mwNUSd7wySwsX1ZXp_R26H1fkyNHg@mail.gmail.com
State New
Headers show

Commit Message

Janus Weil Jan. 3, 2015, 11:29 a.m. UTC 
Hi all,

the attached patch allows type-bound procedures to be passed actual
arguments to dummy procedures. When doing this, on has to transform
the expression such that the corresponding procedure pointer from the
vtab is used.

The patch is regtested on x86_64-unknown-linux-gnu. Ok for trunk?

Cheers,
Janus


2015-01-03  Janus Weil  <janus@gcc.gnu.org>

    PR fortran/63552
    * primary.c (gfc_match_varspec): Handle type-bound procedures as actual
    argument to dummy procedure.

2015-01-03  Janus Weil  <janus@gcc.gnu.org>

    PR fortran/63552
    * gfortran.dg/typebound_proc_34.f90: New.

Comments

Tobias Burnus Jan. 3, 2015, 9:52 p.m. UTC | #1 
Hi Janus,

Janus Weil wrote:
> the attached patch allows type-bound procedures to be passed actual
> arguments to dummy procedures. When doing this, on has to transform
> the expression such that the corresponding procedure pointer from the
> vtab is used.
> ...
> +	  else if (sym->ts.type == BT_CLASS)
> +	    {
> +	      gfc_add_vptr_component (primary);
> +	      gfc_add_component_ref (primary, name);
> +	    }
> +	  else if (sym->ts.type == BT_DERIVED)
> +	    {

If the procedure is NON_OVERRIDABLE, it should be directly called 
without the detour through the vptr.

Tobias
diff mbox

Patch

Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(Revision 219159)
+++ gcc/fortran/primary.c	(Arbeitskopie)
@@ -1826,6 +1826,7 @@  gfc_match_varspec (gfc_expr *primary, int equiv_fl
   gfc_ref *substring, *tail;
   gfc_component *component;
   gfc_symbol *sym = primary->symtree->n.sym;
+  gfc_symbol *dt = NULL;
   match m;
   bool unknown;
 
@@ -1929,7 +1930,7 @@  gfc_match_varspec (gfc_expr *primary, int equiv_fl
       || gfc_match_char ('%') != MATCH_YES)
     goto check_substring;
 
-  sym = sym->ts.u.derived;
+  dt = sym->ts.u.derived;
 
   for (;;)
     {
@@ -1942,8 +1943,8 @@  gfc_match_varspec (gfc_expr *primary, int equiv_fl
       if (m != MATCH_YES)
 	return MATCH_ERROR;
 
-      if (sym->f2k_derived)
-	tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus);
+      if (dt->f2k_derived)
+	tbp = gfc_find_typebound_proc (dt, &t, name, false, &gfc_current_locus);
       else
 	tbp = NULL;
 
@@ -1950,6 +1951,7 @@  gfc_match_varspec (gfc_expr *primary, int equiv_fl
       if (tbp)
 	{
 	  gfc_symbol* tbp_sym;
+	  gfc_actual_arglist *actual = NULL;
 
 	  if (!t)
 	    return MATCH_ERROR;
@@ -1967,37 +1969,48 @@  gfc_match_varspec (gfc_expr *primary, int equiv_fl
 	  else
 	    tbp_sym = tbp->n.tb->u.specific->n.sym;
 
-	  primary->expr_type = EXPR_COMPCALL;
-	  primary->value.compcall.tbp = tbp->n.tb;
-	  primary->value.compcall.name = tbp->name;
-	  primary->value.compcall.ignore_pass = 0;
-	  primary->value.compcall.assign = 0;
-	  primary->value.compcall.base_object = NULL;
-	  gcc_assert (primary->symtree->n.sym->attr.referenced);
 	  if (tbp_sym)
 	    primary->ts = tbp_sym->ts;
 	  else
 	    gfc_clear_ts (&primary->ts);
 
-	  m = gfc_match_actual_arglist (tbp->n.tb->subroutine,
-					&primary->value.compcall.actual);
+	  m = gfc_match_actual_arglist (tbp->n.tb->subroutine, &actual);
 	  if (m == MATCH_ERROR)
 	    return MATCH_ERROR;
-	  if (m == MATCH_NO)
+	  if (m == MATCH_YES || sub_flag)
 	    {
-	      if (sub_flag)
-		primary->value.compcall.actual = NULL;
-	      else
-		{
-		  gfc_error ("Expected argument list at %C");
-		  return MATCH_ERROR;
-		}
+	      primary->expr_type = EXPR_COMPCALL;
+	      primary->value.compcall.tbp = tbp->n.tb;
+	      primary->value.compcall.name = tbp->name;
+	      primary->value.compcall.ignore_pass = 0;
+	      primary->value.compcall.assign = 0;
+	      primary->value.compcall.base_object = NULL;
+	      primary->value.compcall.actual = actual;
+	      gcc_assert (primary->symtree->n.sym->attr.referenced);
 	    }
+	  else if (!matching_actual_arglist)
+	    {
+	      gfc_error ("Expected argument list at %C");
+	      return MATCH_ERROR;
+	    }
+	  else if (sym->ts.type == BT_CLASS)
+	    {
+	      gfc_add_vptr_component (primary);
+	      gfc_add_component_ref (primary, name);
+	    }
+	  else if (sym->ts.type == BT_DERIVED)
+	    {
+	      gfc_symtree *symtree;
+	      gfc_symbol *vtab = gfc_find_derived_vtab (dt);
+	      gfc_find_sym_tree (vtab->name, NULL, 1, &symtree);
+	      primary->symtree = symtree;
+	      gfc_add_component_ref (primary, name);
+	    }
 
 	  break;
 	}
 
-      component = gfc_find_component (sym, name, false, false);
+      component = gfc_find_component (dt, name, false, false);
       if (component == NULL)
 	return MATCH_ERROR;
 
@@ -2005,7 +2018,7 @@  gfc_match_varspec (gfc_expr *primary, int equiv_fl
       tail->type = REF_COMPONENT;
 
       tail->u.c.component = component;
-      tail->u.c.sym = sym;
+      tail->u.c.sym = dt;
 
       primary->ts = component->ts;
 
@@ -2058,12 +2071,12 @@  gfc_match_varspec (gfc_expr *primary, int equiv_fl
 	  || gfc_match_char ('%') != MATCH_YES)
 	break;
 
-      sym = component->ts.u.derived;
+      dt = component->ts.u.derived;
     }
 
 check_substring:
   unknown = false;
-  if (primary->ts.type == BT_UNKNOWN && sym->attr.flavor != FL_DERIVED)
+  if (primary->ts.type == BT_UNKNOWN && !dt)
     {
       if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
        {