OSDN Git Service

2010-07-19 Paul Thomas <pault@gcc.gnu.org>
authorpault <pault@138bc75d-0d04-0410-961f-82ee72b054a4>
Mon, 19 Jul 2010 18:48:44 +0000 (18:48 +0000)
committerpault <pault@138bc75d-0d04-0410-961f-82ee72b054a4>
Mon, 19 Jul 2010 18:48:44 +0000 (18:48 +0000)
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-19  Paul Thomas  <pault@gcc.gnu.org>

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

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@162313 138bc75d-0d04-0410-961f-82ee72b054a4

gcc/fortran/ChangeLog
gcc/fortran/interface.c
gcc/fortran/resolve.c
gcc/fortran/trans-decl.c
gcc/testsuite/ChangeLog
gcc/testsuite/gfortran.dg/class_defined_operator_1.f03 [new file with mode: 0644]

index a903c8a..423a4f1 100644 (file)
@@ -1,5 +1,22 @@
 2010-07-19  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-19  Paul Thomas  <pault@gcc.gnu.org>
+
        PR fortran/44353
        * match.c (gfc_match_iterator): Reverted.
 
index 587b09c..201961d 100644 (file)
@@ -2779,12 +2779,14 @@ gfc_find_sym_in_symtree (gfc_symbol *sym)
 /* 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).  */
+   (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)
+                      gfc_intrinsic_op op, const char* uop,
+                      const char ** gname)
 {
   gfc_actual_arglist* base;
 
@@ -2850,6 +2852,7 @@ matching_typebound_op (gfc_expr** tb_base,
                if (matches)
                  {
                    *tb_base = base->expr;
+                   *gname = g->specific_st->name;
                    return g->specific;
                  }
              }
@@ -2868,11 +2871,12 @@ matching_typebound_op (gfc_expr** tb_base,
 
 static void
 build_compcall_for_operator (gfc_expr* e, gfc_actual_arglist* actual,
-                            gfc_expr* base, gfc_typebound_proc* target)
+                            gfc_expr* base, gfc_typebound_proc* target,
+                            const char *gname)
 {
   e->expr_type = EXPR_COMPCALL;
   e->value.compcall.tbp = target;
-  e->value.compcall.name = "operator"; /* Should not matter.  */
+  e->value.compcall.name = gname ? gname : "$op";
   e->value.compcall.actual = actual;
   e->value.compcall.base_object = base;
   e->value.compcall.ignore_pass = 1;
@@ -2898,6 +2902,7 @@ gfc_extend_expr (gfc_expr *e, bool *real_error)
   gfc_namespace *ns;
   gfc_user_op *uop;
   gfc_intrinsic_op i;
+  const char *gname;
 
   sym = NULL;
 
@@ -2905,6 +2910,7 @@ gfc_extend_expr (gfc_expr *e, bool *real_error)
   actual->expr = e->value.op.op1;
 
   *real_error = false;
+  gname = NULL;
 
   if (e->value.op.op2 != NULL)
     {
@@ -2970,7 +2976,7 @@ gfc_extend_expr (gfc_expr *e, bool *real_error)
       /* 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);
+                                    i, e->value.op.uop->name, &gname);
       else
        switch (i)
          {
@@ -2978,10 +2984,10 @@ gfc_extend_expr (gfc_expr *e, bool *real_error)
   case INTRINSIC_##comp: \
   case INTRINSIC_##comp##_OS: \
     tbo = matching_typebound_op (&tb_base, actual, \
-                                INTRINSIC_##comp, NULL); \
+                                INTRINSIC_##comp, NULL, &gname); \
     if (!tbo) \
       tbo = matching_typebound_op (&tb_base, actual, \
-                                  INTRINSIC_##comp##_OS, NULL); \
+                                  INTRINSIC_##comp##_OS, NULL, &gname); \
     break;
            CHECK_OS_COMPARISON(EQ)
            CHECK_OS_COMPARISON(NE)
@@ -2992,7 +2998,7 @@ gfc_extend_expr (gfc_expr *e, bool *real_error)
 #undef CHECK_OS_COMPARISON
 
            default:
-             tbo = matching_typebound_op (&tb_base, actual, i, NULL);
+             tbo = matching_typebound_op (&tb_base, actual, i, NULL, &gname);
              break;
          }
              
@@ -3003,7 +3009,7 @@ gfc_extend_expr (gfc_expr *e, bool *real_error)
          gfc_try result;
 
          gcc_assert (tb_base);
-         build_compcall_for_operator (e, actual, tb_base, tbo);
+         build_compcall_for_operator (e, actual, tb_base, tbo, gname);
 
          result = gfc_resolve_expr (e);
          if (result == FAILURE)
@@ -3050,6 +3056,9 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
   gfc_actual_arglist *actual;
   gfc_expr *lhs, *rhs;
   gfc_symbol *sym;
+  const char *gname;
+
+  gname = NULL;
 
   lhs = c->expr1;
   rhs = c->expr2;
@@ -3085,7 +3094,7 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
 
       /* See if we find a matching type-bound assignment.  */
       tbo = matching_typebound_op (&tb_base, actual,
-                                  INTRINSIC_ASSIGN, NULL);
+                                  INTRINSIC_ASSIGN, NULL, &gname);
              
       /* If there is one, replace the expression with a call to it and
         succeed.  */
@@ -3093,7 +3102,7 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
        {
          gcc_assert (tb_base);
          c->expr1 = gfc_get_expr ();
-         build_compcall_for_operator (c->expr1, actual, tb_base, tbo);
+         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 95dbeee..2434be1 100644 (file)
@@ -5480,8 +5480,37 @@ resolve_typebound_function (gfc_expr* e)
   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);
 
@@ -5534,13 +5563,44 @@ resolve_typebound_function (gfc_expr* e)
 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 bd7363d..5932695 100644 (file)
@@ -3249,9 +3249,10 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
 
              /* Deallocate when leaving the scope. Nullifying is not
                 needed.  */
-             tmp = gfc_deallocate_with_status (se.expr, NULL_TREE, true,
-                                               NULL);
-
+             tmp = NULL;
+             if (!sym->attr.result)
+               tmp = gfc_deallocate_with_status (se.expr, NULL_TREE,
+                                                 true, NULL);
              gfc_add_init_cleanup (&try_block, gfc_finish_block (&init), tmp);
            }
        }
index 77e6db5..e266814 100644 (file)
@@ -1,3 +1,8 @@
+2010-07-19  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/42385
+       * gfortran.dg/class_defined_operator_1.f03 : New test.
+
 2010-07-19  Peter Bergner  <bergner@vnet.ibm.com>
 
        * gcc.dg/vect/slp-perm-1.c (main): Make sure loops aren't vectorized.
diff --git a/gcc/testsuite/gfortran.dg/class_defined_operator_1.f03 b/gcc/testsuite/gfortran.dg/class_defined_operator_1.f03
new file mode 100644 (file)
index 0000000..008739e
--- /dev/null
@@ -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