re PR fortran/41706 ([OOP] Calling one TBP as an actual argument of another TBP)

2009-10-21  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41706
	PR fortran/41766
	* match.c (select_type_set_tmp): Set flavor for temporary.
	* resolve.c (resolve_class_typebound_call): Correctly resolve actual
	arguments.

2009-10-21  Janus Weil  <janus@gcc.gnu.org>

	PR fortran/41706
	PR fortran/41766
	* gfortran.dg/class_9.f03: Extended test case.
	* gfortran.dg/select_type_7.f03: New test case.

From-SVN: r153049

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 0528e59310819bc1a40075750f38133603460d3b..b3567e4cff79f4ef425200ea88921da160f1d473 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,11 @@
+2009-10-21  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/41706
+       PR fortran/41766
+       * match.c (select_type_set_tmp): Set flavor for temporary.
+       * resolve.c (resolve_class_typebound_call): Correctly resolve actual
+       arguments.
+
 2009-10-20  Paul Thomas  <pault@gcc.gnu.org>
 
        PR fortran/41706

diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 87216062becaba53946a795f25ee1e5829e1a4b8..0a418c8a44930f837c406c0f0e04c24954e7cdaf 100644 (file)
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -4047,9 +4047,10 @@ select_type_set_tmp (gfc_typespec *ts)
 
   sprintf (name, "tmp$%s", ts->u.derived->name);
   gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
-  tmp->n.sym->ts = *ts;
-  tmp->n.sym->attr.referenced = 1;
-  tmp->n.sym->attr.pointer = 1;
+  gfc_add_type (tmp->n.sym, ts, NULL);
+  gfc_set_sym_referenced (tmp->n.sym);
+  gfc_add_pointer (&tmp->n.sym->attr, NULL);
+  gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
 
   select_type_stack->tmp = tmp;
 }

diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 42b6e76fc3a0106a50b7f22362d73d07b3b7eccd..8e23308d5b248cedd6b16ac3c65df04b8ad027fa 100644 (file)
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -5369,7 +5369,7 @@ resolve_class_typebound_call (gfc_code *code)
     } 
 
   /* Resolve the argument expressions,  */
-  resolve_arg_exprs (code->ext.actual); 
+  resolve_arg_exprs (code->expr1->value.compcall.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 b36838b17556d6748ef80b82f0ce98d2663098b4..d5cb9eb7d3e84c9f2e3e7fa9e49a9afc28d34d79 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2009-10-21  Janus Weil  <janus@gcc.gnu.org>
+
+       PR fortran/41706
+       PR fortran/41766
+       * gfortran.dg/class_9.f03: Extended test case.
+       * gfortran.dg/select_type_7.f03: New test case.
+
 2009-10-20  Richard Guenther  <rguenther@suse.de>
 
        * gcc.dg/lto/20091020-3_0.c: New testcase.

diff --git a/gcc/testsuite/gfortran.dg/class_9.f03 b/gcc/testsuite/gfortran.dg/class_9.f03
index 9e19869b219dc6fb8241cbbec47854c9b1eeeb47..5dbd4597abd189cef89eea523f4548775faccb4b 100644 (file)
--- a/gcc/testsuite/gfortran.dg/class_9.f03
+++ b/gcc/testsuite/gfortran.dg/class_9.f03
@@ -11,6 +11,7 @@ contains
   procedure, nopass :: a
   procedure, nopass :: b
   procedure, pass :: c
+  procedure, nopass :: d
 end type
 
 contains
@@ -30,6 +31,11 @@ contains
     c = 4.*x%v
   end function
 
+  subroutine d (x)
+    real :: x
+    if (abs(x-3.0)>1E-3) call abort()
+  end subroutine
+
   subroutine s (x)
     class(t) :: x
     real :: r
@@ -48,6 +54,8 @@ contains
     r = x%a(x%c ())   ! failed
     if (r .ne. a(c (x))) call abort
 
+    call x%d (x%a(1.5))  ! failed
+
   end subroutine
 
 end

diff --git a/gcc/testsuite/gfortran.dg/select_type_7.f03 b/gcc/testsuite/gfortran.dg/select_type_7.f03
new file mode 100644 (file)
index 0000000..554b6cd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/select_type_7.f03
@@ -0,0 +1,40 @@
+! { dg-do run }
+!
+! PR 41766: [OOP] SELECT TYPE selector as actual argument with INTENT(INOUT)
+!
+! Contributed by Janus Weil <janus@gcc.gnu.org>
+
+ implicit none
+
+ type t1
+   integer :: a
+ end type
+
+ type, extends(t1) :: t2
+   integer :: b
+ end type
+
+ class(t1),allocatable :: cp
+
+ allocate(t2 :: cp)
+
+ select type (cp)
+   type is (t2)
+     cp%a = 98
+     cp%b = 76
+     call s(cp)
+     print *,cp%a,cp%b
+     if (cp%a /= cp%b) call abort()
+   class default
+     call abort()
+ end select
+
+contains
+
+  subroutine s(f)
+    type(t2), intent(inout) :: f
+    f%a = 3
+    f%b = 3
+  end subroutine
+
+end