http://gcc.gnu.org/bugzilla/show_bug.cgi?id=55057
Bug #: 55057
Summary: [OOP] wrong result with abstract type
Classification: Unclassified
Product: gcc
Version: 4.8.0
Status: UNCONFIRMED
Severity: normal
Priority: P3
Component: fortran
AssignedTo: unassig...@gcc.gnu.org
ReportedBy: mreste...@gmail.com
The attached code compiles and runs, but the results are not correct.
Unfortunately the reduced test is not very much reduced, however I
think the problem is that in alt the storages of x, y and z overlap.
Notice that the problem is present only when calling alt through an
additional subroutine sub, as indicated by the comments.
gfortran --version
GNU Fortran (GCC) 4.8.0 20121024 (experimental)
./test
All the following values should be 2.0
2.00000000
2.00000000
2.00000000
All the following values should be 2.0
2.00000000
3.00000000
6.00000000
module m
implicit none
public :: &
at1, at2, t1, t2, sub
private
type, abstract :: at1
contains
procedure(i_copy), deferred, pass(z) :: copy
procedure(i_incr), deferred, pass(x) :: incr
procedure(i_tims), deferred, pass(x) :: tims
procedure(i_show), deferred, pass(x) :: show
procedure, pass(z) :: add
procedure, pass(z) :: mlt
procedure, pass(z) :: alt
end type at1
abstract interface
pure subroutine i_copy(z,x)
import :: at1
implicit none
class(at1), intent(in) :: x
class(at1), intent(inout) :: z
end subroutine i_copy
end interface
abstract interface
pure subroutine i_incr(x,y)
import :: at1
implicit none
class(at1), intent(in) :: y
class(at1), intent(inout) :: x
end subroutine i_incr
end interface
abstract interface
pure subroutine i_tims(x,r)
import :: at1
implicit none
real, intent(in) :: r
class(at1), intent(inout) :: x
end subroutine i_tims
end interface
abstract interface
subroutine i_show(x)
import :: at1
implicit none
class(at1), intent(in) :: x
end subroutine i_show
end interface
type, abstract :: at2
class(at1), allocatable :: work(:)
end type at2
type, extends(at1) :: t1
real, allocatable :: f(:)
contains
procedure, pass(x) :: incr
procedure, pass(x) :: tims
procedure, pass(z) :: copy
procedure, pass(x) :: show
end type t1
type, extends(at2) :: t2
end type t2
contains
subroutine alt(z,x,r,y)
real, intent(in) :: r
class(at1), intent(in) :: x, y
class(at1), intent(inout) :: z
print *, 'All the following values should be 2.0'
call y%show()
call z%mlt(r,y) ! z = r * y
call y%show()
call z%incr(x) ! z = z + x
call y%show()
end subroutine alt
pure subroutine add(z,x,y)
class(at1), intent(in) :: x, y
class(at1), intent(inout) :: z
call z%copy( x )
call z%incr( y )
end subroutine add
pure subroutine mlt(z,r,x)
real, intent(in) :: r
class(at1), intent(in) :: x
class(at1), intent(inout) :: z
call z%copy( x )
call z%tims( r )
end subroutine mlt
pure subroutine copy(z,x)
class(at1), intent(in) :: x
class(t1), intent(inout) :: z
select type(x); type is(t1)
z%f = x%f
end select
end subroutine copy
pure subroutine incr(x,y)
class(at1), intent(in) :: y
class(t1), intent(inout) :: x
select type(y); type is(t1)
x%f = x%f + y%f
end select
end subroutine incr
pure subroutine tims(x,r)
real, intent(in) :: r
class(t1), intent(inout) :: x
x%f = r*x%f
end subroutine tims
subroutine show(x)
class(t1), intent(in) :: x
write(*,*) x%f
end subroutine show
subroutine sub(var)
class(at2), intent(inout) :: var
call var%work(2)%alt(var%work(1),1.5,var%work(1))
end subroutine sub
end module m
program p
use m, only: t1, t2, sub
implicit none
integer :: i
type(t2) :: aa
allocate(t1::aa%work(2))
select type(y=>aa%work); type is(t1)
do i=1,2
allocate(y(i)%f(1))
y(i)%f = 2.0
enddo
end select
! This call to ALT works as expected
call aa%work(2)%alt(aa%work(1),1.5,aa%work(1))
! Calling ALT from SUB however does not work
call sub(aa)
end program p
