OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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

Browse Source 
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
This commit is contained in:
Janus Weil 2009-10-21 10:56:56 +02:00
parent ea524613af
commit aa9aed0019
6 changed files with 68 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
gcc/fortran/ChangeLog
View File

@ -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

7
gcc/fortran/match.c
View File

@ -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;
}

2
gcc/fortran/resolve.c
View File

@ -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;

7
gcc/testsuite/ChangeLog
View File

@ -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.

8
gcc/testsuite/gfortran.dg/class_9.f03
View File

@ -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

40
gcc/testsuite/gfortran.dg/select_type_7.f03 Normal file
View File

@ -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