From aa9aed001981645070c365bfde5911cc941d37f2 Mon Sep 17 00:00:00 2001 From: Janus Weil Date: Wed, 21 Oct 2009 10:56:56 +0200 Subject: [PATCH] re PR fortran/41706 ([OOP] Calling one TBP as an actual argument of another TBP) 2009-10-21 Janus Weil 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 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 --- gcc/fortran/ChangeLog | 8 +++++ gcc/fortran/match.c | 7 ++-- gcc/fortran/resolve.c | 2 +- gcc/testsuite/ChangeLog | 7 ++++ gcc/testsuite/gfortran.dg/class_9.f03 | 8 +++++ gcc/testsuite/gfortran.dg/select_type_7.f03 | 40 +++++++++++++++++++++ 6 files changed, 68 insertions(+), 4 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/select_type_7.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 0528e593108..b3567e4cff7 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2009-10-21 Janus Weil + + 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 PR fortran/41706 diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 87216062bec..0a418c8a449 100644 --- 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 42b6e76fc3a..8e23308d5b2 100644 --- 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 b36838b1755..d5cb9eb7d3e 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2009-10-21 Janus Weil + + 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 * 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 9e19869b219..5dbd4597abd 100644 --- 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 index 00000000000..554b6cd122d --- /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 + + 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