Commit b7ddd3f1 by Paul Thomas

re PR fortran/67933 (ICE for array of a derived type with allocatable class in derived type object)

2015-01-27  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/67933
	* gfortran.dg/allocate_with_source_15.f03: New test

From-SVN: r229452
parent 33497fd2
2015-01-27 Paul Thomas <pault@gcc.gnu.org>
PR fortran/67933
* gfortran.dg/allocate_with_source_15.f03: New test
2015-10-27 Thomas Schwinge <thomas@codesourcery.com>
James Norris <jnorris@codesourcery.com>
......
! { dg-do run }
!
! Tests the fix for PR67933, which was a side effect of the fix for PR67171.
!
! Contributed by Andrew <mandrew9@vt.edu>
!
module test_mod
implicit none
type :: class_t
integer :: i
end type class_t
type, extends(class_t) :: class_e
real :: r
end type class_e
type :: wrapper_t
class(class_t), allocatable :: class_var
! type(class_t), allocatable :: class_var
! integer, allocatable :: class_id
end type wrapper_t
type :: list_t
type(wrapper_t) :: classes(10)
contains
procedure :: Method
procedure :: Typeme
procedure :: Dealloc
end type list_t
contains
subroutine Method(this)
class(list_t) :: this
integer :: i
do i = 1, 20
if (i .gt. 10) then
allocate (this%classes(i)%class_var, source = class_t (i))
else
allocate (this%classes(i)%class_var, source = class_e (i, real (2 * i)))
end if
end do
end subroutine Method
subroutine Dealloc(this)
class(list_t) :: this
integer :: i
do i = 1, 20
if (allocated (this%classes(i)%class_var)) &
deallocate (this%classes(i)%class_var)
end do
end subroutine Dealloc
subroutine Typeme(this)
class(list_t) :: this
integer :: i, j(20)
real :: r(20)
real :: zero = 0.0
do i = 1, 20
j(i) = this%classes(i)%class_var%i
select type (p => this%classes(i)%class_var)
type is (class_e)
r(i) = p%r
class default
r(i) = zero
end select
end do
! print "(10i6,/)", j
if (any (j .ne. [(i, i = 1,20)])) call abort
! print "(10f6.2,/)", r
if (any (r(1:10) .ne. [(real (2 * i), i = 1,10)])) call abort
if (any (r(11:20) .ne. zero)) call abort
end subroutine Typeme
end module test_mod
use test_mod
type(list_t) :: x
call x%Method
call x%Typeme
call x%dealloc
end
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment