re PR fortran/41556 ([OOP] Errors in applying operator/assignment to an abstract type)

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.

From-SVN: r153946

gcc/fortran/ChangeLog

 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

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

gcc/testsuite/ChangeLog

+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

gcc/testsuite/gfortran.dg/class_12.f03

+! { 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" } }