[Patch, fortran] PR41706 - [OOP] Calling one TBP as an actual argument of another TBP

[Paul Richard Thomas <paul.richard.thomas@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 893 bytes --]

Dear All,

The PR comes about because of the use of static variables in the
resolution of typebound procedures in classes.  If calls to these
procedures are nested by having actual argument expressions involving
such calls, then an internal compiler error ensues.  The fix is simply
to resolve the actual argument expressions first.

Bootstrapped and regtested on FC9/x86_64

The original testcase had the allocation within subroutine 's'.  This
segfaults at -O2, with the fourth, extra test, because the allocation
is optimized away.  I will investigate and raise a separate PR.

Cheers

Paul

2009-10-19  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/41706
	* resolve.c (resolve_arg_exprs): New function.
	(resolve_class_compcall): Call the above.
	(resolve_class_typebound_call): The same.

2009-10-19  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/41706
	* gfortran.dg/class_9 : New test.

[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 3297 bytes --]

Index: gcc/fortran/resolve.c
===================================================================
*** gcc/fortran/resolve.c	(revision 152966)
--- gcc/fortran/resolve.c	(working copy)
*************** get_declared_from_expr (gfc_ref **class_
*** 5275,5280 ****
--- 5275,5296 ----
  }
  
  
+ /* Resolve the argument expressions so that any arguments expressions
+    that include class methods are resolved before the current call.
+    This is necessary because of the static variables used in CLASS
+    method resolution.  */
+ static void
+ resolve_arg_exprs (gfc_actual_arglist *arg)
+ { 
+   /* Resolve the actual arglist expressions.  */
+   for (; arg; arg = arg->next)
+     {
+       if (arg->expr)
+ 	gfc_resolve_expr (arg->expr);
+     }
+ }
+ 
+ 
  /* Resolve a CLASS typebound function, or 'method'.  */
  static gfc_try
  resolve_class_compcall (gfc_expr* e)
*************** resolve_class_compcall (gfc_expr* e)
*** 5295,5301 ****
      {
        gfc_free_ref_list (new_ref);
        return resolve_compcall (e, true);
!     } 
  
    /* Get the data component, which is of the declared type.  */
    derived = declared->components->ts.u.derived;
--- 5311,5320 ----
      {
        gfc_free_ref_list (new_ref);
        return resolve_compcall (e, true);
!     }
! 
!   /* Resolve the argument expressions,  */
!   resolve_arg_exprs (e->value.function.actual); 
  
    /* Get the data component, which is of the declared type.  */
    derived = declared->components->ts.u.derived;
*************** resolve_class_typebound_call (gfc_code *
*** 5349,5354 ****
--- 5368,5376 ----
        return resolve_typebound_call (code);
      } 
  
+   /* Resolve the argument expressions,  */
+   resolve_arg_exprs (code->ext.actual); 
+ 
    /* Get the data component, which is of the declared type.  */
    derived = declared->components->ts.u.derived;
  
Index: gcc/testsuite/gfortran.dg/class_9.f03
===================================================================
*** gcc/testsuite/gfortran.dg/class_9.f03	(revision 0)
--- gcc/testsuite/gfortran.dg/class_9.f03	(revision 0)
***************
*** 0 ****
--- 1,60 ----
+ ! { dg-do run }
+ ! Test the fix for PR41706, in which arguments of class methods that
+ ! were themselves class methods did not work.
+ !
+ ! Contributed by Janus Weil <janus@gcc.gnu.org>
+ !
+ module m
+ type :: t
+   real :: v = 1.5
+ contains
+   procedure, nopass :: a
+   procedure, nopass :: b
+   procedure, pass :: c
+ end type
+ 
+ contains
+ 
+   real function a (x)
+     real :: x
+     a = 2.*x
+   end function
+ 
+   real function b (x)
+     real :: x
+     b = 3.*x
+   end function
+ 
+   real function c (x)
+     class (t) :: x
+     c = 4.*x%v
+   end function
+ 
+   subroutine s (x)
+     class(t) :: x
+     real :: r
+     r = x%a (1.1)       ! worked
+     if (r .ne. a (1.1)) call abort
+ 
+     r = x%a (b (1.2))   ! worked
+     if (r .ne. a(b (1.2))) call abort
+ 
+     r = b ( x%a (1.3))  ! worked
+     if (r .ne. b(a (1.3))) call abort
+ 
+     r = x%a(x%b (1.4))   ! failed
+     if (r .ne. a(b (1.4))) call abort
+ 
+     r = x%a(x%c ())   ! failed
+     if (r .ne. a(c (x))) call abort
+ 
+   end subroutine
+ 
+ end
+ 
+   use m
+   class(t),allocatable :: x
+   allocate(x)
+   call s (x)
+ end
+ ! { dg-final { cleanup-modules "m" } }