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

[Janus Weil]

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  <ja...@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  <ja...@gcc.gnu.org>

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

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)
        {

! { dg-do run }
!
! PR 63552: [OOP] Type-bound procedures rejected as actual argument to dummy procedure
!
! Contributed by Tobias Burnus <bur...@gcc.gnu.org>

module m
  type t
  contains
    procedure, nopass :: tbp => f
  end type
contains
  pure integer function f(a,b)
    integer, intent(in) :: a,b
    f = a + b
  end function
end module

program test
  use m
  integer :: a
  class(t), allocatable :: x
  type(t) :: y
  call sub(f)
  call sub(x%tbp)
  call sub(y%tbp)
contains
  subroutine sub(arg)
    procedure(f) :: arg
    if (f(1,2)/=3) call abort
  end subroutine
end

! { dg-final { cleanup-modules "m" } }