Patchwork [fortran] PR42385 - [OOP] poylmorphic operators do not work

login
register
mail settings
Submitter Paul Richard Thomas
Date July 18, 2010, 6:05 p.m.
Message ID <AANLkTilImUQz78ZIe7y7Bx4A7MNrxBDZGOVLCnWn-xzq@mail.gmail.com>
Download mbox | patch
Permalink /patch/59171/
State New
Headers show

Comments

Paul Richard Thomas - July 18, 2010, 6:05 p.m.
The attached patch implements defined operators for CLASS objects.

Along the way, I correct a buglet that nullified allocatable scalar
results, thereby causing the testcase to fail.

Boostrapped and regtested on x86_64/FC9 - OK for trunk?

Paul

2010-07-18  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/42385
	* interface.c (matching_typebound_op): Add argument for the
	return of the generic name for the procedure.
	(build_compcall_for_operator): Add an argument for the generic
	name of an operator procedure and supply it to the expression.
	(gfc_extend_expr, gfc_extend_assign): Use the generic name in
	calls to the above procedures.
	* resolve.c (resolve_typebound_function): Catch procedure
	component calls for CLASS objects, check that the vtable is
	complete and insert the $vptr and procedure components, to make
	the call.
	(resolve_typebound_function): The same.
	* trans-decl.c (gfc_trans_deferred_vars): Do not deallocate
	an allocatable scalar if it is a result.


2010-07-18  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/42385
	* gfortran.dg/class_defined_operator_1.f03 : New test.

Patch

Index: gcc/fortran/interface.c
===================================================================
*** gcc/fortran/interface.c	(revision 162285)
--- gcc/fortran/interface.c	(working copy)
*************** gfc_find_sym_in_symtree (gfc_symbol *sym
*** 2779,2790 ****
  /* See if the arglist to an operator-call contains a derived-type argument
     with a matching type-bound operator.  If so, return the matching specific
     procedure defined as operator-target as well as the base-object to use
!    (which is the found derived-type argument with operator).  */
  
  static gfc_typebound_proc*
  matching_typebound_op (gfc_expr** tb_base,
  		       gfc_actual_arglist* args,
! 		       gfc_intrinsic_op op, const char* uop)
  {
    gfc_actual_arglist* base;
  
--- 2779,2792 ----
  /* See if the arglist to an operator-call contains a derived-type argument
     with a matching type-bound operator.  If so, return the matching specific
     procedure defined as operator-target as well as the base-object to use
!    (which is the found derived-type argument with operator).  The generic
!    name, if any, is transmitted to the final expression via 'gname'.  */
  
  static gfc_typebound_proc*
  matching_typebound_op (gfc_expr** tb_base,
  		       gfc_actual_arglist* args,
! 		       gfc_intrinsic_op op, const char* uop,
! 		       const char ** gname)
  {
    gfc_actual_arglist* base;
  
*************** matching_typebound_op (gfc_expr** tb_bas
*** 2850,2855 ****
--- 2852,2858 ----
  		if (matches)
  		  {
  		    *tb_base = base->expr;
+ 		    *gname = g->specific_st->name;
  		    return g->specific;
  		  }
  	      }
*************** matching_typebound_op (gfc_expr** tb_bas
*** 2868,2878 ****
  
  static void
  build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
! 			     gfc_expr* base, gfc_typebound_proc* target)
  {
    e->expr_type = EXPR_COMPCALL;
    e->value.compcall.tbp = target;
!   e->value.compcall.name = "operator"; /* Should not matter.  */
    e->value.compcall.actual = actual;
    e->value.compcall.base_object = base;
    e->value.compcall.ignore_pass = 1;
--- 2871,2882 ----
  
  static void
  build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
! 			     gfc_expr* base, gfc_typebound_proc* target,
! 			     const char *gname)
  {
    e->expr_type = EXPR_COMPCALL;
    e->value.compcall.tbp = target;
!   e->value.compcall.name = gname ? gname : "$op";
    e->value.compcall.actual = actual;
    e->value.compcall.base_object = base;
    e->value.compcall.ignore_pass = 1;
*************** gfc_extend_expr (gfc_expr *e, bool *real
*** 2898,2903 ****
--- 2902,2908 ----
    gfc_namespace *ns;
    gfc_user_op *uop;
    gfc_intrinsic_op i;
+   const char *gname;
  
    sym = NULL;
  
*************** gfc_extend_expr (gfc_expr *e, bool *real
*** 2905,2910 ****
--- 2910,2916 ----
    actual->expr = e->value.op.op1;
  
    *real_error = false;
+   gname = NULL;
  
    if (e->value.op.op2 != NULL)
      {
*************** gfc_extend_expr (gfc_expr *e, bool *real
*** 2970,2976 ****
        /* See if we find a matching type-bound operator.  */
        if (i == INTRINSIC_USER)
  	tbo = matching_typebound_op (&tb_base, actual,
! 				     i, e->value.op.uop->name);
        else
  	switch (i)
  	  {
--- 2976,2982 ----
        /* See if we find a matching type-bound operator.  */
        if (i == INTRINSIC_USER)
  	tbo = matching_typebound_op (&tb_base, actual,
! 				     i, e->value.op.uop->name, &gname);
        else
  	switch (i)
  	  {
*************** gfc_extend_expr (gfc_expr *e, bool *real
*** 2978,2987 ****
    case INTRINSIC_##comp: \
    case INTRINSIC_##comp##_OS: \
      tbo = matching_typebound_op (&tb_base, actual, \
! 				 INTRINSIC_##comp, NULL); \
      if (!tbo) \
        tbo = matching_typebound_op (&tb_base, actual, \
! 				   INTRINSIC_##comp##_OS, NULL); \
      break;
  	    CHECK_OS_COMPARISON(EQ)
  	    CHECK_OS_COMPARISON(NE)
--- 2984,2993 ----
    case INTRINSIC_##comp: \
    case INTRINSIC_##comp##_OS: \
      tbo = matching_typebound_op (&tb_base, actual, \
! 				 INTRINSIC_##comp, NULL, &gname); \
      if (!tbo) \
        tbo = matching_typebound_op (&tb_base, actual, \
! 				   INTRINSIC_##comp##_OS, NULL, &gname); \
      break;
  	    CHECK_OS_COMPARISON(EQ)
  	    CHECK_OS_COMPARISON(NE)
*************** gfc_extend_expr (gfc_expr *e, bool *real
*** 2992,2998 ****
  #undef CHECK_OS_COMPARISON
  
  	    default:
! 	      tbo = matching_typebound_op (&tb_base, actual, i, NULL);
  	      break;
  	  }
  	      
--- 2998,3004 ----
  #undef CHECK_OS_COMPARISON
  
  	    default:
! 	      tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
  	      break;
  	  }
  	      
*************** gfc_extend_expr (gfc_expr *e, bool *real
*** 3003,3009 ****
  	  gfc_try result;
  
  	  gcc_assert (tb_base);
! 	  build_compcall_for_operator (e, actual, tb_base, tbo);
  
  	  result = gfc_resolve_expr (e);
  	  if (result == FAILURE)
--- 3009,3015 ----
  	  gfc_try result;
  
  	  gcc_assert (tb_base);
! 	  build_compcall_for_operator (e, actual, tb_base, tbo, gname);
  
  	  result = gfc_resolve_expr (e);
  	  if (result == FAILURE)
*************** gfc_extend_assign (gfc_code *c, gfc_name
*** 3050,3055 ****
--- 3056,3064 ----
    gfc_actual_arglist *actual;
    gfc_expr *lhs, *rhs;
    gfc_symbol *sym;
+   const char *gname;
+ 
+   gname = NULL;
  
    lhs = c->expr1;
    rhs = c->expr2;
*************** gfc_extend_assign (gfc_code *c, gfc_name
*** 3085,3091 ****
  
        /* See if we find a matching type-bound assignment.  */
        tbo = matching_typebound_op (&tb_base, actual,
! 				   INTRINSIC_ASSIGN, NULL);
  	      
        /* If there is one, replace the expression with a call to it and
  	 succeed.  */
--- 3094,3100 ----
  
        /* See if we find a matching type-bound assignment.  */
        tbo = matching_typebound_op (&tb_base, actual,
! 				   INTRINSIC_ASSIGN, NULL, &gname);
  	      
        /* If there is one, replace the expression with a call to it and
  	 succeed.  */
*************** gfc_extend_assign (gfc_code *c, gfc_name
*** 3093,3099 ****
  	{
  	  gcc_assert (tb_base);
  	  c->expr1 = gfc_get_expr ();
! 	  build_compcall_for_operator (c->expr1, actual, tb_base, tbo);
  	  c->expr1->value.compcall.assign = 1;
  	  c->expr2 = NULL;
  	  c->op = EXEC_COMPCALL;
--- 3102,3108 ----
  	{
  	  gcc_assert (tb_base);
  	  c->expr1 = gfc_get_expr ();
! 	  build_compcall_for_operator (c->expr1, actual, tb_base, tbo, gname);
  	  c->expr1->value.compcall.assign = 1;
  	  c->expr2 = NULL;
  	  c->op = EXEC_COMPCALL;
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 162285)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_typebound_function (gfc_expr* e)
*** 5480,5487 ****
--- 5480,5516 ----
    gfc_symtree *st;
    const char *name;
    gfc_typespec ts;
+   gfc_expr *expr;
  
    st = e->symtree;
+ 
+   /* Deal with typebound operators for CLASS objects.  */
+   expr = e->value.compcall.base_object;
+   if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
+ 	&& e->value.compcall.name)
+     {
+       /* Since the typebound operators are generic, we have to ensure
+ 	 that any delays in resolution are corrected and that the vtab
+ 	 is present.  */
+       ts = expr->symtree->n.sym->ts;
+       declared = ts.u.derived;
+       c = gfc_find_component (declared, "$vptr", true, true);
+       if (c->ts.u.derived == NULL)
+ 	c->ts.u.derived = gfc_find_derived_vtab (declared);
+ 
+       if (resolve_compcall (e, &name) == FAILURE)
+ 	return FAILURE;
+ 
+       /* Use the generic name if it is there.  */
+       name = name ? name : e->value.function.esym->name;
+       e->symtree = expr->symtree;
+       expr->symtree->n.sym->ts.u.derived = declared;
+       gfc_add_component_ref (e, "$vptr");
+       gfc_add_component_ref (e, name);
+       e->value.function.esym = NULL;
+       return SUCCESS;
+     }
+ 
    if (st == NULL)
      return resolve_compcall (e, NULL);
  
*************** resolve_typebound_function (gfc_expr* e)
*** 5534,5546 ****
--- 5563,5606 ----
  static gfc_try
  resolve_typebound_subroutine (gfc_code *code)
  {
+   gfc_symbol *declared;
+   gfc_component *c;
    gfc_ref *new_ref;
    gfc_ref *class_ref;
    gfc_symtree *st;
    const char *name;
    gfc_typespec ts;
+   gfc_expr *expr;
  
    st = code->expr1->symtree;
+ 
+   /* Deal with typebound operators for CLASS objects.  */
+   expr = code->expr1->value.compcall.base_object;
+   if (expr && expr->symtree->n.sym->ts.type == BT_CLASS
+ 	&& code->expr1->value.compcall.name)
+     {
+       /* Since the typebound operators are generic, we have to ensure
+ 	 that any delays in resolution are corrected and that the vtab
+ 	 is present.  */
+       ts = expr->symtree->n.sym->ts;
+       declared = ts.u.derived;
+       c = gfc_find_component (declared, "$vptr", true, true);
+       if (c->ts.u.derived == NULL)
+ 	c->ts.u.derived = gfc_find_derived_vtab (declared);
+ 
+       if (resolve_typebound_call (code, &name) == FAILURE)
+ 	return FAILURE;
+ 
+       /* Use the generic name if it is there.  */
+       name = name ? name : code->expr1->value.function.esym->name;
+       code->expr1->symtree = expr->symtree;
+       expr->symtree->n.sym->ts.u.derived = declared;
+       gfc_add_component_ref (code->expr1, "$vptr");
+       gfc_add_component_ref (code->expr1, name);
+       code->expr1->value.function.esym = NULL;
+       return SUCCESS;
+     }
+ 
    if (st == NULL)
      return resolve_typebound_call (code, NULL);
  
Index: gcc/testsuite/gfortran.dg/class_defined_operator_1.f03
===================================================================
*** gcc/testsuite/gfortran.dg/class_defined_operator_1.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/class_defined_operator_1.f03	(revision 0)
***************
*** 0 ****
--- 1,102 ----
+ ! { dg-do run }
+ ! Test the fix for PR42385, in which CLASS defined operators
+ ! compiled but were not correctly dynamically dispatched.
+ !
+ ! Contributed by Janus Weil  <janus@gcc.gnu.org>
+ !
+ module foo_module
+  implicit none
+  private
+  public :: foo
+ 
+  type :: foo
+    integer :: foo_x
+  contains
+    procedure :: times => times_foo
+    procedure :: assign => assign_foo
+    generic :: operator(*) => times
+    generic :: assignment(=) => assign
+  end type
+ 
+ contains
+ 
+    function times_foo(this,factor) result(product)
+      class(foo) ,intent(in) :: this
+      class(foo) ,allocatable :: product
+      integer, intent(in) :: factor
+      allocate (product, source = this)
+      product%foo_x = -product%foo_x * factor
+    end function
+ 
+    subroutine assign_foo(lhs,rhs)
+      class(foo) ,intent(inout) :: lhs
+      class(foo) ,intent(in) :: rhs
+      lhs%foo_x = -rhs%foo_x
+    end subroutine
+ 
+ end module
+ 
+ module bar_module
+  use foo_module ,only : foo
+  implicit none
+  private
+  public :: bar
+ 
+  type ,extends(foo) :: bar
+    integer :: bar_x
+  contains
+    procedure :: times => times_bar
+    procedure :: assign => assign_bar
+  end type
+ 
+ contains
+  subroutine assign_bar(lhs,rhs)
+    class(bar) ,intent(inout) :: lhs
+    class(foo) ,intent(in) :: rhs
+    select type(rhs)
+      type is (bar)
+        lhs%bar_x = rhs%bar_x
+        lhs%foo_x = -rhs%foo_x
+    end select
+  end subroutine
+  function times_bar(this,factor) result(product)
+    class(bar) ,intent(in) :: this
+    integer, intent(in) :: factor
+    class(foo), allocatable :: product
+    select type(this)
+      type is (bar)
+        allocate(product,source=this)
+        select type(product)
+          type is(bar)
+            product%bar_x = 2*this%bar_x*factor
+        end select
+    end select
+  end function
+ end module
+ 
+ program main
+  use foo_module ,only : foo
+  use bar_module ,only : bar
+  implicit none
+  type(foo) :: unitf
+  type(bar) :: unitb
+ 
+ ! foo's assign negates, whilst its '*' negates and mutliplies.
+  unitf%foo_x = 1
+  call rescale(unitf, 42)
+  if (unitf%foo_x .ne. 42) call abort
+ 
+ ! bar's assign negates foo_x, whilst its '*' copies foo_x
+ ! and does a multiply by twice factor.
+  unitb%foo_x = 1
+  unitb%bar_x = 2
+  call rescale(unitb, 3)
+  if (unitb%bar_x .ne. 12) call abort
+  if (unitb%foo_x .ne. -1) call abort
+ contains
+  subroutine rescale(this,scale)
+    class(foo) ,intent(inout) :: this
+    integer, intent(in) :: scale
+    this = this*scale
+  end subroutine
+ end program