re PR fortran/41648 ([OOP] Type-bound procedures refused)

2009-10-16  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/41648
	PR fortran/41656
	* trans-expr.c (select_class_proc): Convert the expression for the
	vindex, carried on the first member of the esym list.
	* gfortran.h : Add the vindex field to the esym_list structure.
	and eliminate the class_object field.
	* resolve.c (check_class_members): Remove the setting of the
	class_object field.
	(vindex_expr): New function.
	(get_class_from_expr): New function.
	(resolve_class_compcall): Call the above to find the ultimate
	class or derived component.  If derived, do not generate the
	esym list.  Add and expression for the vindex to the esym list
	by calling the above.
	(resolve_class_typebound_call): The same.

2009-10-16  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/41648
	* gfortran.dg/dynamic_dispatch_4.f03 : New test.

	PR fortran/41656
	* gfortran.dg/dynamic_dispatch_5.f03 : New test.

From-SVN: r152890

gcc/fortran/ChangeLog

+2009-10-16  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/41648
+	PR fortran/41656
+	* trans-expr.c (select_class_proc): Convert the expression for the
+	vindex, carried on the first member of the esym list.
+	* gfortran.h : Add the vindex field to the esym_list structure.
+	and eliminate the class_object field.
+	* resolve.c (check_class_members): Remove the setting of the
+	class_object field.
+	(vindex_expr): New function.
+	(get_class_from_expr): New function.
+	(resolve_class_compcall): Call the above to find the ultimate
+	class or derived component.  If derived, do not generate the
+	esym list.  Add and expression for the vindex to the esym list
+	by calling the above.
+	(resolve_class_typebound_call): The same.
+
 2009-10-15  Steven G. Kargl  <kargl@gcc.gnu.org>
 
 	PR fortran/41712

gcc/fortran/resolve.c

@@ -5161,8 +5161,6 @@ check_class_members (gfc_symbol *derived)
 		= gfc_get_class_esym_list();
       list_e->value.function.class_esym->next = etmp;
       list_e->value.function.class_esym->derived = derived;
-      list_e->value.function.class_esym->class_object
-		= class_object;
       list_e->value.function.class_esym->esym
 		= e->value.function.esym;
     }
@@ -5206,19 +5204,101 @@ resolve_class_esym (gfc_expr *e)
 }
 
 
+/* Generate an expression for the vindex, given the reference to
+   the class of the final expression (class_ref), the base of the
+   full reference list (new_ref), the declared type and the class
+   object (st).  */
+static gfc_expr*
+vindex_expr (gfc_ref *class_ref, gfc_ref *new_ref,
+	     gfc_symbol *declared, gfc_symtree *st)
+{
+  gfc_expr *vindex;
+  gfc_ref *ref;
+
+  /* Build an expression for the correct vindex; ie. that of the last
+     CLASS reference.  */
+  ref = gfc_get_ref();
+  ref->type = REF_COMPONENT;
+  ref->u.c.component = declared->components->next;
+  ref->u.c.sym = declared;
+  ref->next = NULL;
+  if (class_ref)
+    {
+      class_ref->next = ref;
+    }
+  else
+    {
+      gfc_free_ref_list (new_ref);
+      new_ref = ref;
+    }
+  vindex = gfc_get_expr ();
+  vindex->expr_type = EXPR_VARIABLE;
+  vindex->symtree = st;
+  vindex->symtree->n.sym->refs++;
+  vindex->ts = ref->u.c.component->ts;
+  vindex->ref = new_ref;
+
+  return vindex;
+}
+
+
+/* Get the ultimate declared type from an expression.  In addition,
+   return the last class/derived type reference and the copy of the
+   reference list.  */
+static gfc_symbol*
+get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
+			gfc_expr *e)
+{
+  gfc_symbol *declared;
+  gfc_ref *ref;
+
+  declared = NULL;
+  *class_ref = NULL;
+  *new_ref = gfc_copy_ref (e->ref);
+  for (ref = *new_ref; ref; ref = ref->next)
+    {
+      if (ref->type != REF_COMPONENT)
+	continue;
+
+      if (ref->u.c.component->ts.type == BT_CLASS
+	    || ref->u.c.component->ts.type == BT_DERIVED)
+	{
+	  declared = ref->u.c.component->ts.u.derived;
+	  *class_ref = ref;
+	}
+    }
+
+  if (declared == NULL)
+    declared = e->symtree->n.sym->ts.u.derived;
+
+  return declared;
+}
+
+
 /* Resolve a CLASS typebound function, or 'method'.  */
 static gfc_try
 resolve_class_compcall (gfc_expr* e)
 {
-  gfc_symbol *derived;
+  gfc_symbol *derived, *declared;
+  gfc_ref *new_ref;
+  gfc_ref *class_ref;
+  gfc_symtree *st;
+
+  st = e->symtree;
+  class_object = st->n.sym;
 
-  class_object = e->symtree->n.sym;
+  /* Get the CLASS declared type.  */
+  declared = get_declared_from_expr (&class_ref, &new_ref, e);
 
-  /* Get the CLASS type.  */
-  derived = e->symtree->n.sym->ts.u.derived;
+  /* Weed out cases of the ultimate component being a derived type.  */
+  if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
+    {
+      gfc_free_ref_list (new_ref);
+      return resolve_compcall (e, true);
+    } 
 
   /* Get the data component, which is of the declared type.  */
-  derived = derived->components->ts.u.derived;
+  derived = declared->components->ts.u.derived;
 
   /* Resolve the function call for each member of the class.  */
   class_try = SUCCESS;
@@ -5238,6 +5318,12 @@ resolve_class_compcall (gfc_expr* e)
 
   resolve_class_esym (e);
 
+  /* More than one typebound procedure so transmit an expression for
+     the vindex as the selector.  */
+  if (e->value.function.class_esym != NULL)
+    e->value.function.class_esym->vindex
+		= vindex_expr (class_ref, new_ref, declared, st);
+
   return class_try;
 }
 
@@ -5245,15 +5331,26 @@ resolve_class_compcall (gfc_expr* e)
 static gfc_try
 resolve_class_typebound_call (gfc_code *code)
 {
-  gfc_symbol *derived;
+  gfc_symbol *derived, *declared;
+  gfc_ref *new_ref;
+  gfc_ref *class_ref;
+  gfc_symtree *st;
+
+  st = code->expr1->symtree;
+  class_object = st->n.sym;
 
-  class_object = code->expr1->symtree->n.sym;
+  /* Get the CLASS declared type.  */
+  declared = get_declared_from_expr (&class_ref, &new_ref, code->expr1);
 
-  /* Get the CLASS type.  */
-  derived = code->expr1->symtree->n.sym->ts.u.derived;
+  /* Weed out cases of the ultimate component being a derived type.  */
+  if (class_ref && class_ref->u.c.component->ts.type == BT_DERIVED)
+    {
+      gfc_free_ref_list (new_ref);
+      return resolve_typebound_call (code);
+    } 
 
   /* Get the data component, which is of the declared type.  */
-  derived = derived->components->ts.u.derived;
+  derived = declared->components->ts.u.derived;
 
   class_try = SUCCESS;
   fcn_flag = false;
@@ -5273,6 +5370,12 @@ resolve_class_typebound_call (gfc_code *code)
 
   resolve_class_esym (code->expr1);
 
+  /* More than one typebound procedure so transmit an expression for
+     the vindex as the selector.  */
+  if (code->expr1->value.function.class_esym != NULL)
+    code->expr1->value.function.class_esym->vindex
+		= vindex_expr (class_ref, new_ref, declared, st);
+
   return class_try;
 }
 

gcc/fortran/trans-expr.c

@@ -1527,7 +1527,7 @@ 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 declared, gfc_expr *expr)
 {
   tree end_label;
   tree label;
@@ -1535,16 +1535,16 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
   tree vindex;
   stmtblock_t body;
   gfc_class_esym_list *next_elist, *tmp_elist;
+  gfc_se tmpse;
 
-  /* 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);
+  /* Convert the vindex expression.  */
+  gfc_init_se (&tmpse, NULL);
+  gfc_conv_expr (&tmpse, elist->vindex);
+  gfc_add_block_to_block (&se->pre, &tmpse.pre);
+  vindex = 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.  */
+  /* 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);
@@ -1603,6 +1603,8 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
 	 segfaults because it occurs too early and too often.  */
     free_elist:
       next_elist = elist->next;
+      if (elist->vindex)
+	gfc_free_expr (elist->vindex);
       gfc_free (elist);
       elist = NULL;
     }
@@ -1612,7 +1614,7 @@ select_class_proc (gfc_se *se, gfc_class_esym_list *elist,
   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,
+  tmp = gfc_trans_runtime_error (true, &expr->where,
 		"internal error: bad vindex in dynamic dispatch");
   gfc_add_expr_to_block (&body, tmp);
 
@@ -1649,7 +1651,7 @@ conv_function_val (gfc_se * se, gfc_symbol * sym, gfc_expr * expr)
 	}
 
       select_class_proc (se, expr->value.function.class_esym,
-			 tmp, &expr->where);
+			 tmp, expr);
       return;
     }
 

gcc/testsuite/ChangeLog

+2009-10-16  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/41648
+	* gfortran.dg/dynamic_dispatch_4.f03 : New test.
+
+	PR fortran/41656
+	* gfortran.dg/dynamic_dispatch_5.f03 : New test.
+
 2009-10-15  Michael Meissner  <meissner@linux.vnet.ibm.com>
 
 	PR target/23983

gcc/testsuite/gfortran.dg/dynamic_dispatch_4.f03

+! { dg-do run }
+! Tests the fix for PR41648 in which the reference a%a%getit () was wrongly
+! identified as a recursive call to getit.
+!
+! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
+!
+module foo_mod
+  type foo
+    integer :: i 
+  contains
+    procedure, pass(a) :: doit
+    procedure, pass(a) :: getit
+  end type foo
+  
+  private doit,getit
+contains
+  subroutine  doit(a) 
+    class(foo) :: a
+    
+    a%i = 1
+  end subroutine doit
+  function getit(a) result(res)
+    class(foo) :: a
+    integer :: res
+
+    res = a%i
+  end function getit
+    
+end module foo_mod
+
+module s_bar_mod 
+  use foo_mod
+  type, extends(foo) :: s_bar 
+    type(foo), allocatable :: a
+  contains 
+    procedure, pass(a) :: doit
+    procedure, pass(a) :: getit
+  end type s_bar
+  private doit,getit
+  
+contains
+  subroutine doit(a)
+    class(s_bar) :: a
+    allocate (a%a)   
+    call a%a%doit()
+  end subroutine doit
+  function getit(a) result(res)
+    class(s_bar) :: a
+    integer :: res
+
+    res = a%a%getit () * 2
+  end function getit
+end module s_bar_mod
+
+module a_bar_mod 
+  use foo_mod
+  type, extends(foo) :: a_bar 
+    type(foo), allocatable :: a(:)
+  contains 
+    procedure, pass(a) :: doit
+    procedure, pass(a) :: getit
+  end type a_bar
+  private doit,getit
+  
+contains
+  subroutine doit(a)
+    class(a_bar) :: a
+    allocate (a%a(1))   
+    call a%a(1)%doit ()
+  end subroutine doit
+  function getit(a) result(res)
+    class(a_bar) :: a
+    integer :: res
+
+    res = a%a(1)%getit () * 3
+  end function getit
+end module a_bar_mod
+
+  use s_bar_mod
+  use a_bar_mod
+  type(foo), target :: b
+  type(s_bar), target :: c
+  type(a_bar), target :: d
+  class(foo), pointer :: a
+  a => b
+  call a%doit
+  if (a%getit () .ne. 1) call abort
+  a => c
+  call a%doit
+  if (a%getit () .ne. 2) call abort
+  a => d
+  call a%doit
+  if (a%getit () .ne. 3) call abort
+end
+! { dg-final { cleanup-modules "foo_mod s_bar_mod a_bar_mod" } }
+

gcc/testsuite/gfortran.dg/dynamic_dispatch_5.f03

+! { dg-do compile }
+! Tests the fix for PR4164656 in which the call to a%a%scal failed to compile.
+!
+! Contributed by Salvatore Filippone <sfilippone@uniroma2.it>
+!
+module const_mod
+  integer, parameter  :: longndig=12
+  integer, parameter  :: long_int_k_ = selected_int_kind(longndig)
+  integer, parameter  :: dpk_ = kind(1.d0)
+  integer, parameter  :: spk_ = kind(1.e0)
+end module const_mod
+
+module base_mat_mod  
+  use const_mod 
+  type  :: base_sparse_mat
+    integer, private     :: m, n
+    integer, private     :: state, duplicate 
+    logical, private     :: triangle, unitd, upper, sorted
+  contains 
+    procedure, pass(a) :: get_nzeros
+  end type base_sparse_mat
+  private ::  get_nzeros
+contains
+  function get_nzeros(a) result(res)
+    implicit none 
+    class(base_sparse_mat), intent(in) :: a
+    integer :: res
+    integer :: err_act
+    character(len=20)  :: name='base_get_nzeros'
+    logical, parameter :: debug=.false.
+    res = -1
+  end function get_nzeros
+end module base_mat_mod
+
+module s_base_mat_mod
+  use base_mat_mod
+  type, extends(base_sparse_mat) :: s_base_sparse_mat
+  contains
+    procedure, pass(a) :: s_scals
+    procedure, pass(a) :: s_scal
+    generic, public    :: scal => s_scals, s_scal 
+  end type s_base_sparse_mat
+  private :: s_scals, s_scal
+
+  type, extends(s_base_sparse_mat) :: s_coo_sparse_mat
+    
+    integer              :: nnz
+    integer, allocatable :: ia(:), ja(:)
+    real(spk_), allocatable :: val(:)
+  contains
+    procedure, pass(a) :: get_nzeros => s_coo_get_nzeros
+    procedure, pass(a) :: s_scals => s_coo_scals
+    procedure, pass(a) :: s_scal => s_coo_scal
+  end type s_coo_sparse_mat
+  private :: s_coo_scals, s_coo_scal, s_coo_get_nzeros
+contains 
+  subroutine s_scals(d,a,info) 
+    implicit none 
+    class(s_base_sparse_mat), intent(in) :: a
+    real(spk_), intent(in)      :: d
+    integer, intent(out)            :: info
+
+    Integer :: err_act
+    character(len=20)  :: name='s_scals'
+    logical, parameter :: debug=.false.
+
+    ! This is the base version. If we get here
+    ! it means the derived class is incomplete,
+    ! so we throw an error.
+    info = 700
+  end subroutine s_scals
+
+
+  subroutine s_scal(d,a,info) 
+    implicit none 
+    class(s_base_sparse_mat), intent(in) :: a
+    real(spk_), intent(in)      :: d(:)
+    integer, intent(out)            :: info
+
+    Integer :: err_act
+    character(len=20)  :: name='s_scal'
+    logical, parameter :: debug=.false.
+
+    ! This is the base version. If we get here
+    ! it means the derived class is incomplete,
+    ! so we throw an error.
+    info = 700
+  end subroutine s_scal
+
+  function s_coo_get_nzeros(a) result(res)
+    implicit none 
+    class(s_coo_sparse_mat), intent(in) :: a
+    integer :: res
+    res  = a%nnz
+  end function s_coo_get_nzeros
+
+
+  subroutine s_coo_scal(d,a,info) 
+    use const_mod
+    implicit none 
+    class(s_coo_sparse_mat), intent(inout) :: a
+    real(spk_), intent(in)      :: d(:)
+    integer, intent(out)            :: info
+
+    Integer :: err_act,mnm, i, j, m
+    character(len=20)  :: name='scal'
+    logical, parameter :: debug=.false.
+    info  = 0
+    do i=1,a%get_nzeros()
+      j        = a%ia(i)
+      a%val(i) = a%val(i) * d(j)
+    enddo
+  end subroutine s_coo_scal
+
+  subroutine s_coo_scals(d,a,info) 
+    use const_mod
+    implicit none 
+    class(s_coo_sparse_mat), intent(inout) :: a
+    real(spk_), intent(in)      :: d
+    integer, intent(out)            :: info
+
+    Integer :: err_act,mnm, i, j, m
+    character(len=20)  :: name='scal'
+    logical, parameter :: debug=.false.
+
+    info  = 0
+    do i=1,a%get_nzeros()
+      a%val(i) = a%val(i) * d
+    enddo
+  end subroutine s_coo_scals
+end module s_base_mat_mod
+
+module s_mat_mod
+  use s_base_mat_mod
+  type :: s_sparse_mat
+    class(s_base_sparse_mat), pointer  :: a
+  contains
+    procedure, pass(a) :: s_scals
+    procedure, pass(a) :: s_scal
+    generic, public    :: scal => s_scals, s_scal 
+  end type s_sparse_mat
+  interface scal
+    module procedure s_scals, s_scal
+  end interface
+contains 
+  subroutine s_scal(d,a,info)
+    use const_mod
+    implicit none 
+    class(s_sparse_mat), intent(inout) :: a
+    real(spk_), intent(in)              :: d(:)
+    integer, intent(out)                    :: info
+    integer :: err_act
+    character(len=20)  :: name='csnmi'
+    logical, parameter :: debug=.false.
+    print *, "s_scal"
+    call a%a%scal(d,info)
+    return
+  end subroutine s_scal
+
+  subroutine s_scals(d,a,info)
+    use const_mod
+    implicit none 
+    class(s_sparse_mat), intent(inout) :: a
+    real(spk_), intent(in)              :: d
+    integer, intent(out)                    :: info
+    integer :: err_act
+    character(len=20)  :: name='csnmi'
+    logical, parameter :: debug=.false.
+    print *, "s_scals"
+    call a%a%scal(d,info)
+    return
+  end subroutine s_scals
+end module s_mat_mod
+
+    use s_mat_mod
+    class (s_sparse_mat), pointer :: a
+    type (s_sparse_mat), target :: b
+    type (s_base_sparse_mat), target :: c
+    integer info
+    b%a => c
+    a => b
+    call a%scal (1.0_spk_, info)
+end
+! { dg-final { cleanup-modules "const_mod base_mat_mod s_base_mat_mod s_mat_mod" } }
+