[Patch, fortran] PR51791 - [OOP] Failure to resolve typebound function call with base object in parentheses

[Paul Richard Thomas <paul dot richard dot thomas at gmail dot com>]

Dear All,

Having stated in the PR that I did not have time to fix it, after a
few hours in the workshop doing woodwork I alighted on the obvious and
simple solution :-)

A question for the standard aficianados: Are there other base object
expressions that are legal? Clearly this fix is extendable.

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

Paul

2012-01-08  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/PR51791
	* interface.c (matching_typebound_op): Drill down through
	possible parentheses to obtain base expression.
	* resolve.c (resolve_ordinary_assign): Extend error message for
	polymorphic assignment to advise checking for specific
	subroutine.

2012-01-08  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/PR51791
	* gfortran.dg/typebound_operator_7.f03: Insert parentheses
	around base object in first assignment in main program.
	* gfortran.dg/typebound_operator_7.f03: New test.

Index: gcc/testsuite/gfortran.dg/typebound_operator_10.f03
===================================================================
*** gcc/testsuite/gfortran.dg/typebound_operator_10.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/typebound_operator_10.f03	(revision 0)
***************
*** 0 ****
--- 1,29 ----
+ ! { dg-do compile }
+ ! PR51791 and original testcase for PR46328.
+ !
+ ! Contributer by Thomas Koenig  <tkoenig@gcc.gnu.org>
+ !
+ module field_module
+   implicit none
+   type ,abstract :: field
+   contains
+     procedure(field_op_real) ,deferred :: multiply_real
+     generic :: operator(*) => multiply_real
+   end type
+   abstract interface
+     function field_op_real(lhs,rhs)
+       import :: field
+       class(field) ,intent(in)  :: lhs
+       real ,intent(in) :: rhs
+       class(field) ,allocatable :: field_op_real
+     end function
+   end interface
+ end module
+ 
+ program main
+   use field_module
+   implicit none
+   class(field) ,pointer :: u
+   u = (u)*2. ! { dg-error "check that there is a matching specific" }
+ end program
+ ! { dg-final { cleanup-modules "field_module" } }
Index: gcc/testsuite/gfortran.dg/typebound_operator_7.f03
===================================================================
*** gcc/testsuite/gfortran.dg/typebound_operator_7.f03	(revision 182988)
--- gcc/testsuite/gfortran.dg/typebound_operator_7.f03	(working copy)
*************** program main
*** 90,96 ****
    class(i_field) ,allocatable :: u
    allocate (u, source = i_field (99))
  
!   u = u*2.
    u = (u*2.0*4.0) + u*4.0
    u = u%multiply_real (2.0)*4.0
    u = i_multiply_real (u, 2.0) * 4.0
--- 90,96 ----
    class(i_field) ,allocatable :: u
    allocate (u, source = i_field (99))
  
!   u = (u)*2.
    u = (u*2.0*4.0) + u*4.0
    u = u%multiply_real (2.0)*4.0
    u = i_multiply_real (u, 2.0) * 4.0
Index: gcc/fortran/interface.c
===================================================================
*** gcc/fortran/interface.c	(revision 182988)
--- gcc/fortran/interface.c	(working copy)
*************** matching_typebound_op (gfc_expr** tb_bas
*** 3168,3173 ****
--- 3168,3177 ----
  	gfc_symbol* derived;
  	gfc_try result;
  
+ 	while (base->expr->expr_type == EXPR_OP
+ 	       && base->expr->value.op.op == INTRINSIC_PARENTHESES)
+ 	  base->expr = base->expr->value.op.op1;
+ 
  	if (base->expr->ts.type == BT_CLASS)
  	  {
  	    if (!gfc_expr_attr (base->expr).class_ok)
Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 182988)
--- gcc/fortran/resolve.c	(working copy)
*************** resolve_ordinary_assign (gfc_code *code,
*** 9208,9215 ****
       and coindexed; cf. F2008, 7.2.1.2 and PR 43366.  */
    if (lhs->ts.type == BT_CLASS)
      {
!       gfc_error ("Variable must not be polymorphic in assignment at %L",
! 		 &lhs->where);
        return false;
      }
  
--- 9208,9216 ----
       and coindexed; cf. F2008, 7.2.1.2 and PR 43366.  */
    if (lhs->ts.type == BT_CLASS)
      {
!       gfc_error ("Variable must not be polymorphic in assignment at %L "
! 		 "- check that there is a matching specific subroutine "
! 		 "for '=' operator", &lhs->where);
        return false;
      }