2009-10-20 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-20  Paul Thomas  <pault@gcc.gnu.org>

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

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index ce18d2d..0528e59 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,10 @@
+2009-10-20  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  Janus Weil  <janus@gcc.gnu.org>
 
        PR fortran/41586

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 285228c..42b6e76 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -5275,6 +5275,22 @@ get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref,
 }
 
 
+/* 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)
@@ -5295,7 +5311,10 @@ resolve_class_compcall (gfc_expr* e)
     {
       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;
@@ -5349,6 +5368,9 @@ resolve_class_typebound_call (gfc_code *code)
       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;
 

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index c91c4d4..ad3b360 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,8 @@
+2009-10-20  Paul Thomas  <pault@gcc.gnu.org>
+
+       PR fortran/41706
+       * gfortran.dg/class_9 : New test.
+
 2009-10-19  Jakub Jelinek  <jakub@redhat.com>
 
        * gcc.dg/raw-string-1.c: New test.

diff --git a/gcc/testsuite/gfortran.dg/class_9.f03 b/gcc/testsuite/gfortran.dg/class_9.f03
new file mode 100644 (file)
index 0000000..9e19869
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_9.f03
@@ -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" } }