2009-11-05 Janus Weil <janus@gcc.gnu.org>

	PR fortran/41556
	* interface.c (matching_typebound_op,gfc_extend_assign): Handle CLASS
	variables.

2009-11-05  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41556
	* gfortran.dg/class_12.f03: New test.

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index dca8031..3a1aa63 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,6 +1,12 @@
 2009-11-05  Janus Weil  <janus@gcc.gnu.org>
 
        PR fortran/41556
+       * interface.c (matching_typebound_op,gfc_extend_assign): Handle CLASS
+       variables.
+
+2009-11-05  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/41556
        PR fortran/41873
        * resolve.c (resolve_function,resolve_call): Prevent abstract interfaces
        from being called, but allow deferred type-bound procedures with

diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
index 05e5d2d..866a81c 100644 (file)
--- a/gcc/fortran/interface.c
+++ b/gcc/fortran/interface.c
@@ -2574,13 +2574,16 @@ matching_typebound_op (gfc_expr** tb_base,
   gfc_actual_arglist* base;
 
   for (base = args; base; base = base->next)
-    if (base->expr->ts.type == BT_DERIVED)
+    if (base->expr->ts.type == BT_DERIVED || base->expr->ts.type == BT_CLASS)
       {
        gfc_typebound_proc* tb;
        gfc_symbol* derived;
        gfc_try result;
 
-       derived = base->expr->ts.u.derived;
+       if (base->expr->ts.type == BT_CLASS)
+         derived = base->expr->ts.u.derived->components->ts.u.derived;
+       else
+         derived = base->expr->ts.u.derived;
 
        if (op == INTRINSIC_USER)
          {
@@ -2837,7 +2840,7 @@ gfc_extend_assign (gfc_code *c, gfc_namespace *ns)
   rhs = c->expr2;
 
   /* Don't allow an intrinsic assignment to be replaced.  */
-  if (lhs->ts.type != BT_DERIVED
+  if (lhs->ts.type != BT_DERIVED && lhs->ts.type != BT_CLASS
       && (rhs->rank == 0 || rhs->rank == lhs->rank)
       && (lhs->ts.type == rhs->ts.type
          || (gfc_numeric_ts (&lhs->ts) && gfc_numeric_ts (&rhs->ts))))

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 42d6ced..5246897 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2009-11-05  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/41556
+       * gfortran.dg/class_12.f03: New test.
+
 2009-11-05  Jakub Jelinek  <jakub@redhat.com>
 
        * gcc.target/i386/i386.exp (check_effective_target_xop): Fix typo

diff --git a/gcc/testsuite/gfortran.dg/class_12.f03 b/gcc/testsuite/gfortran.dg/class_12.f03
new file mode 100644 (file)
index 0000000..56c68a5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_12.f03
@@ -0,0 +1,45 @@
+! { dg-do compile }
+!
+! PR 41556: [OOP] Errors in applying operator/assignment to an abstract type
+!
+! Contributed by Damian Rouson <damian@rouson.net>
+
+module abstract_algebra
+  implicit none 
+  private      
+  public :: rescale
+  public :: object
+
+  type ,abstract :: object
+  contains
+    procedure(assign_interface) ,deferred :: assign   
+    procedure(product_interface) ,deferred :: product
+    generic  :: assignment(=) => assign
+    generic  :: operator(*) => product
+  end type 
+
+  abstract interface
+    function product_interface(lhs,rhs) result(product)
+      import :: object
+      class(object) ,intent(in)  :: lhs
+      class(object) ,allocatable :: product
+      real          ,intent(in)  :: rhs
+    end function 
+    subroutine assign_interface(lhs,rhs) 
+      import :: object 
+      class(object) ,intent(inout) :: lhs
+      class(object) ,intent(in)    :: rhs
+    end subroutine 
+  end interface
+
+contains
+
+  subroutine rescale(operand,scale)    
+    class(object)    :: operand
+    real ,intent(in) :: scale
+    operand = operand*scale
+    operand = operand%product(scale)
+  end subroutine 
+end module
+
+! { dg-final { cleanup-modules "abstract_algebra" } }