Skip to content

Instantly share code, notes, and snippets.

@drikosev
Last active January 19, 2021 09:50
Show Gist options
  • Save drikosev/a9e9e8357dbc45aeb02773198069222b to your computer and use it in GitHub Desktop.
Save drikosev/a9e9e8357dbc45aeb02773198069222b to your computer and use it in GitHub Desktop.
Deallocations on Intrinsic Assignment
! { dg-do run }
! { dg-shouldfail "Fortran runtime error: Assignment with unallocated RHS 'w'" }
! { dg-output "Fortran runtime error: Assignment with unallocated RHS 'w'" }
! Catch a Runtime error on intrinsic assignment of
! a class LHS with an unallocated RHS.
module testmode
implicit none
integer, public, save :: finalized = 0
integer, public, save :: counting = 0
type :: d0
integer :: ind
contains
final :: destruct0
end type d0
type, extends(d0) :: d1
integer :: i
end type d1
type, extends(d0) :: d2
integer :: j
class(d0), allocatable :: u
end type d2
contains
subroutine destruct0(self)
type(d0), intent(inout) :: self
if ( counting > 0 ) then
print *, "d0 % destruct1(self): ind=", self%ind
finalized = finalized + 1;
end if
end subroutine destruct0
end module testmode
subroutine s
use testmode
implicit none
class(d2), allocatable :: v
class(d1), allocatable :: w
type(d0), save :: allocatable1 = d0(1000)
type(d0), save :: allocatable2 = d0(2000)
print *, "Initializing..."
allocate ( v , source = d2(2,2,allocatable2))
print *, "allocated v = d2(2,2,allocatable2=2000)"
! Reset this as we test only intrinsic assignments
finalized = 0
counting = 1
print *, "set finalized=0"
print *
print *, "-----------------"
print *, "will assign v = w ( not allocated w )"
v = w
print *, "assined v = w, now v%ind=", v%ind, "allocated=", allocated(v)
print *, "-----------------"
print *, "exiting s() ..."
end subroutine s
program test
use testmode
implicit none
call s()
print *, "finalized=", finalized, ", expected= ?"
!if ( finalized /= ? ) error stop
end program test
! { dg-do run }
module testmode
implicit none
integer, public, save :: finalized = 0
integer, public, save :: counting = 0
type :: d0
integer :: ind
contains
final :: destruct1
end type d0
type, extends(d0) :: d1
integer :: i
end type d1
type, extends(d0) :: d2
integer :: j
end type d2
contains
subroutine destruct1(self)
type(d0), intent(inout) :: self
if ( counting > 0 ) then
print *, "d0 % destruct1(self): ind=", self%ind
finalized = finalized + 1;
end if
end subroutine destruct1
end module testmode
subroutine s
use testmode
implicit none
class(d1), allocatable :: x
class(d2), allocatable :: y
class(d2), allocatable :: z
class(d2), allocatable :: v
type(d2), allocatable :: d
allocate(d); d%ind = 100
allocate ( x , source = d1(1,1) )
print *, "allocated x = d1(1,1)"
allocate ( y , source = d2(2,2))
print *, "allocated y = d2(2,2)"
allocate ( z , source = d2(3,3))
print *, "allocated z = d2(3,3)"
allocate ( v , source = d2(4,4))
print *, "allocated v = d2(4,4)"
! Reset this as we test only intrinsic assignments
finalized = 0
counting = 1
print *, "set finalized=0"
print *
print *, "-----------------"
print *, "will assign v = y (same class - shouldn't reallocate)"
v = y
print *, "assined v = y", " and now v%ind=", v%ind
print *
print *, "will assign v = v (shelf)"
v = v
print *, "assined v = v", " and now v%ind=", v%ind
print *
print *, "will assign v = d (same type - reallocation not implemented yet)"
v = d
print *, "assined v = d", " and now v%ind=", v%ind
print *
print *, "will assign v = x (other class)"
v = x
print *, "assined v = x", " and now v%ind=", v%ind
print *
print *, "-----------------"
print *, "Deallocating..."
if (allocated(x)) deallocate( x )
if (allocated(y)) deallocate( y )
if (allocated(z)) deallocate( z )
if (allocated(v)) deallocate( v )
print *, "-----------------"
end subroutine s
program test
use testmode
implicit none
call s()
print *, "finalized=", finalized, ", expected= 6"
if ( finalized /= 6 ) error stop
end program test
! { dg-do run }
!
! Check that the reallocation of a class(*) lhs works.
! Note that the functionality tested isn't for arrays.
module m
integer, public, save :: finalized = 0
integer, public, save :: counting = 0
type :: type_1
integer ind
contains
final :: destruct1
end type type_1
type :: type_2
integer ind
end type type_2
type :: type_3
integer ind,i
end type type_3
contains
subroutine destruct1(self)
type(type_1), intent(inout) :: self
if ( counting > 0 ) then
print *, "type_1 % destruct1(self): ind=", self%ind
finalized = finalized + 1
end if
end subroutine destruct1
end module m
subroutine main()
use m
class(type_1), allocatable :: t1
class(type_2), allocatable :: t2
class(type_3), allocatable :: t3
class(*), allocatable :: u
t1=type_1(1)
t2=type_2(2)
t3=type_3(3,3)
! Reset this as we test only intrinsic assignments
finalized = 0
counting = 1
print *, "set finalized=0"
print *
u=t1; if ( finalized /= 0 ) error stop 1;
u=t2; if ( finalized /= 1 ) error stop 2;
u=t3; if ( finalized /= 1 ) error stop 3;
print *, "exiting..."
end
program p
use m
call main()
print *, "finalized=", finalized, ", expected= 2"
if ( finalized /= 2 ) error stop
end
! { dg-do run }
!
! Check that the reallocation of a class(*) lhs works.
! Note that the functionality tested isn't for arrays.
module m
integer, public, save :: finalized = 0
integer, public, save :: counting = 0
type :: type_1
integer ind
contains
final :: destruct1
end type type_1
type :: type_2
integer ind
end type type_2
type :: type_3
integer ind,i
end type type_3
contains
subroutine destruct1(self)
type(type_1), intent(inout) :: self
if ( counting > 0 ) then
print *, "type_1 % destruct1(self): ind=", self%ind
finalized = finalized + 1
end if
end subroutine destruct1
end module m
subroutine main()
use m
class(type_1), allocatable :: t1
class(type_2), allocatable :: t2
class(type_3), allocatable :: t3
class(*), allocatable :: u
t1=type_1(1)
t2=type_2(2)
t3=type_3(3,3)
! Reset this as we test only intrinsic assignments
finalized = 0
counting = 1
print *, "set finalized=0"
print *
! Check any bug that may execute the finalizer of the RHS.
u=t2; if ( finalized /= 0 ) error stop 1;
u=t1; if ( finalized /= 0 ) error stop 2;
u=t3; if ( finalized /= 1 ) error stop 3;
print *, "exiting..."
end
program p
use m
call main()
print *, "finalized=", finalized, ", expected= 2"
if ( finalized /= 2 ) error stop
end
! { dg-do run }
! Test reallocation of a scalar LHS when RHS is a derived.
module testmode
implicit none
integer, public, save :: finalized = 0
integer, public, save :: counting = 0
type :: d0
integer :: ind
contains
final :: destruct1
end type d0
type, extends(d0) :: d1
integer :: i
end type d1
type, extends(d0) :: d2
integer :: j
end type d2
contains
subroutine destruct1(self)
type(d0), intent(inout) :: self
if ( counting > 0 ) then
print *, "d0 % destruct1(self): ind=", self%ind
finalized = finalized + 1;
end if
end subroutine destruct1
end module testmode
subroutine s2
use testmode
implicit none
class(d1), allocatable :: x
class(d2), allocatable :: y
class(d2), allocatable :: z
class(d0), allocatable :: v
type(d2), allocatable :: d
allocate ( x , source = d1(1,1))
print *, "allocated x = d1(1,1)"
allocate ( d , source = d2(2,2))
print *, "allocated d = d2(2,2)"
allocate ( v , source = d2(4,4))
print *, "allocated v = d2(4,4)"
! Reset this as we test only intrinsic assignments
finalized = 0
counting = 1
print *, "set finalized=0"
print *
print *, "-----------------"
print *, "will assign v = d (same type)"
v = d
print *, "assined v = d, and now v%ind=", v%ind
print *
print *, "will assign v = x (other type)"
v = x
print *, "assined v = x, and now v%ind=", v%ind
print *
print *, "-----------------"
print *, "exiting s2() ..."
end subroutine s2
program test
use testmode
implicit none
call s2()
print *, "finalized=", finalized, ", expected= 4"
if ( finalized /= 4 ) error stop
end program test
! { dg-do run }
! Test reallocation of a scalar LHS when RHS is a derived
! of the same type but with different attributes (pointer).
! Just in case, as they have different vtab at compile time
! and the patch for PR/64290 compares the vptr at runtime.
module testmode
implicit none
integer, public, save :: finalized = 0
integer, public, save :: counting = 0
type :: d0
integer :: ind
contains
final :: destruct1
end type d0
type, extends(d0) :: d1
integer :: i
end type d1
type, extends(d0) :: d2
integer :: j
end type d2
contains
subroutine destruct1(self)
type(d0), intent(inout) :: self
if ( counting > 0 ) then
print *, "d0 % destruct1(self): ind=", self%ind
finalized = finalized + 1;
end if
end subroutine destruct1
end module testmode
subroutine s2
use testmode
implicit none
class(d1), allocatable :: x
class(d2), allocatable :: y
class(d2), allocatable :: z
class(d0), allocatable :: v
type(d2), pointer :: d
allocate ( x , source = d1(1,1))
print *, "allocated x = d1(1,1)"
allocate ( d , source = d2(2,2))
print *, "allocated d = d2(2,2)"
allocate ( v , source = d2(4,4))
print *, "allocated v = d2(4,4)"
! Reset this as we test only intrinsic assignments
finalized = 0
counting = 1
print *, "set finalized=0"
print *
print *, "-----------------"
print *, "will assign v = d (same type)"
v = d
print *, "assined v = d, and now v%ind=", v%ind
print *
print *, "will assign v = x (other type)"
v = x
print *, "assined v = x, and now v%ind=", v%ind
print *
print *, "-----------------"
print *, "exiting s2() ..."
!we explicitly deallocate the pointer object
deallocate(d)
end subroutine s2
program test
use testmode
implicit none
call s2()
print *, "finalized=", finalized, ", expected= 4"
if ( finalized /= 4 ) error stop
end program test
! { dg-do run }
!
! Test intrinsic assignments when the RHS is either a member of
! the LHS or a type-bound procedure (of the LHS). In specific
! two kinds of down-casting are tested here:
!
! v = v%downcast()
! x = x%base
module testmode
implicit none
integer, public, save :: finalized_d0 = 0
integer, public, save :: finalized_d2 = 0
integer, public, save :: counting = 0
type :: d0
type (d0), pointer :: base => null()
integer :: id
contains
final :: destruct_d0
procedure :: downcast => downcast0
end type d0
type, extends(d0) :: d2
integer no
contains
final :: destruct_d2
procedure :: downcast => downcast2
end type d2
interface d0
module procedure construct_d0
end interface
interface d2
module procedure construct_d2
end interface
contains
function construct_d0( id ) result(r)
integer, intent(in) :: id
type(d0) :: r
r%id = id
end function
function construct_d2( id, no ) result(r)
integer, intent(in) :: id, no
type(d2) :: r
r%id = id
r%no = no
end function
subroutine destruct_d0(this)
implicit none
type(d0), intent(inout) :: this
if ( counting > 0 ) then
print *, "finalizing ... (d0), id=", this%id
finalized_d0 = finalized_d0 + 1;
end if
end subroutine destruct_d0
subroutine destruct_d2(this)
implicit none
type(d2), intent(inout) :: this
if ( counting > 0 ) then
print *, "finalizing ... (d2), id=", this%id, "no=", this%no
finalized_d2 = finalized_d2 + 1;
end if
end subroutine destruct_d2
function downcast0(this) result (b)
implicit none
class(d0), intent(inout) :: this
type(d0) :: b
if ( .not. associated(this%base)) this%base = this
b = this%base
end function downcast0
function downcast2(this) result (b)
implicit none
class(d2), intent(inout) :: this
type(d0) :: b
b = downcast0(this)
end function downcast2
end module testmode
subroutine s()
use testmode
implicit none
class(d0), target, allocatable :: v
class(d0), target, allocatable :: x
allocate( v, source = d2(2,2))
print *
print *, "allocated v = d2(2,2)"
v%base => v
print *, "assigned v%base =>v"
allocate( x, source = d2(3,3))
print *
print *, "allocated x = d2(3,3)"
x%base => x
print *, "assigned x%base =>x"
! Reset this as we test only intrinsic assignments
finalized_d0 = 0
finalized_d2 = 0
counting = 1
print *, "set finalized_d0=0, finalized_d2=0"
print *
print *
print *, "will downcast v to d0 ( v = v%downcast() )"
print *, "-------- before -------"
select type (v)
class is (d0)
print *, "runtime type: (d0), id=", v%id, "sizeof(v)=", sizeof(v)
class is (d2)
print *, "runtime type: (d2), id=", v%id, "sizeof(v)=", sizeof(v)
end select
print *, "downcasting ..."
v = v%downcast()
print *, "-------- after --------"
select type (v)
class is (d0)
print *, "runtime type: (d0), id=", v%id, "sizeof(v)=", sizeof(v)
class is (d2)
print *, "runtime type: (d2), id=", v%id, "sizeof(v)=", sizeof(v)
end select
if ( finalized_d2 /= 1 ) error stop 1
if ( finalized_d0 /= 1 ) error stop 2
print *
print *, "will downcast x to d0 ( x = x%base )"
print *, "-------- before -------"
select type (x)
class is (d0)
print *, "runtime type: (d0), id=", x%id, "sizeof(x)=", sizeof(x)
class is (d2)
print *, "runtime type: (d2), id=", x%id, "sizeof(x)=", sizeof(x)
end select
print *, "downcasting ..."
x = x%base
print *, "-------- after --------"
select type (x)
class is (d0)
print *, "runtime type: (d0), id=", x%id, "sizeof(x)=", sizeof(x)
class is (d2)
print *, "runtime type: (d2), id=", x%id, "sizeof(x)=", sizeof(x)
end select
if ( finalized_d2 /= 2 ) error stop 3
if ( finalized_d0 /= 2 ) error stop 4
print *, "-----------------"
print *, "exiting s()..."
end subroutine s
program test
use testmode
implicit none
call s()
print *, "-------- TOTALS ---------"
print *, "finalized_d2=", finalized_d2, ", expected= 2"
print *, "finalized_d0=", finalized_d0, ", expected= 4"
if ( finalized_d2 /= 2 ) error stop 5
if ( finalized_d0 /= 4 ) error stop 6
end program test
macbook:gcc-4.8.5 suser$ gfc -g gcc/testsuite/gfortran.dg/realloc_final_5.f90 && ./a.out
allocated v = d2(2,2)
assigned v%base =>v
allocated x = d2(3,3)
assigned x%base =>x
will downcast v to d0 ( v = v%downcast() )
-------- before -------
runtime type: (d2), id= 2 sizeof(v)= 24
downcasting ...
finalizing ... (d2), id= 2 no= 2
finalizing ... (d0), id= 2
-------- after --------
runtime type: (d0), id= 2 sizeof(v)= 16
will downcast x to d0 ( x = x%base )
-------- before -------
runtime type: (d2), id= 3 sizeof(x)= 24
downcasting ...
finalizing ... (d2), id= 3 no= 3
finalizing ... (d0), id= 3
Program received signal SIGSEGV: Segmentation fault - invalid memory reference.
Backtrace for this error:
#0 0x10be73509
#1 0x10be73d2e
#2 0x7fff5dffbb5c
#3 0x10be67d8d
#4 0x10be690b9
#5 0x10be6959b
#6 0x10be69798
Segmentation fault: 11
macbook:gcc-4.8.5 suser$
macbook:gcc-4.8.5 suser$ gfc -g gcc/testsuite/gfortran.dg/realloc_class_5.f90 && ./a.out
allocated v = d2(2,2)
assigned v%base =>v
allocated x = d2(3,3)
assigned x%base =>x
set finalized_d0=0, finalized_d2=0
will downcast v to d0 ( v = v%downcast() )
-------- before -------
runtime type: (d2), id= 2 sizeof(v)= 24
downcasting ...
finalizing ... (d2), id= 2 no= 2
finalizing ... (d0), id= 2
-------- after --------
runtime type: (d0), id= 2 sizeof(v)= 16
will downcast x to d0 ( x = x%base )
-------- before -------
runtime type: (d2), id= 3 sizeof(x)= 24
downcasting ...
finalizing ... (d2), id= 3 no= 3
finalizing ... (d0), id= 3
-------- after --------
runtime type: (d0), id= 3 sizeof(x)= 16
-----------------
exiting s()...
finalizing ... (d0), id= 3
finalizing ... (d0), id= 2
-------- TOTALS ---------
finalized_d2= 2 , expected= 2
finalized_d0= 4 , expected= 4
macbook:gcc-4.8.5 suser$
! { dg-do run }
! Test reallocation of a scalar LHS with an allocatable
! component.
module testmode
implicit none
integer, public, save :: finalized = 0
integer, public, save :: counting = 0
type :: d0
integer :: ind
contains
final :: destruct0
end type d0
type, extends(d0) :: d1
integer :: i
end type d1
type, extends(d0) :: d2
integer :: j
class(d0), allocatable :: u
end type d2
contains
subroutine destruct0(self)
type(d0), intent(inout) :: self
if ( counting > 0 ) then
print *, "d0 % destruct1(self): ind=", self%ind
finalized = finalized + 1;
end if
end subroutine destruct0
end module testmode
subroutine s
use testmode
implicit none
class(d1), allocatable :: x
class(d0), allocatable :: v
type(d0), save :: allocatable = d0(1000)
print *, "Initializing..."
allocate ( x , source = d1(1,1))
print *, "allocated x = d1(1,1)"
allocate ( v , source = d2(2,2,allocatable))
print *, "allocated v = d2(2,2,allocatable=1000)"
! Reset this as we test only intrinsic assignments
finalized = 0
counting = 1
print *, "set finalized=0"
print *
print *, "-----------------"
print *, "will assign v = x (other class)"
v = x
print *, "assined v = x, now v%ind=", v%ind
print *
print *, "-----------------"
print *, "exiting s() ..."
end subroutine s
program test
use testmode
implicit none
call s()
print *, "finalized=", finalized, ", expected= 4"
if ( finalized /= 4 ) error stop
end program test
! { dg-do run }
! Test reallocation of a scalar LHS with allocatable
! components, larger than 16 bytes, in the base class.
module testmode
implicit none
integer, public, save :: finalized = 0
integer, public, save :: counting = 0
type :: T
character(20) :: ch
end type T
type :: d0
integer :: ind
integer, allocatable :: a
type(T), allocatable :: b
contains
final :: destruct0
end type d0
type, extends(d0) :: d1
integer :: i = 1
end type d1
type, extends(d0) :: d2
integer :: j = 2
end type d2
contains
subroutine destruct0(self)
type(d0), intent(inout) :: self
if ( counting > 0 ) then
print *, "d0 % destruct1(self): ind=", self%ind
finalized = finalized + 1;
end if
end subroutine destruct0
end module testmode
subroutine s
use testmode
implicit none
class(d1), allocatable :: x
class(d0), allocatable :: v
integer, allocatable :: m,n
print *, "Initializing..."
allocate ( m , source = 101)
print *, "allocated m = 101"
allocate ( n , source = 102)
print *, "allocated n = 102"
allocate ( x )
x%ind = 1
x%a = m
x%b = T("_______________Hello")
x%i = 1
print *, "allocated x = d1(1,m,1)"
allocate ( v )
v%ind = 2
v%a = n
v%b = T("_______________World")
print *, "allocated v = d0(2,n)"
! Reset this as we test only intrinsic assignments
finalized = 0
counting = 1
print *, "set finalized=0"
print *
print *, "-----------------"
print *, "before: v = , now v%ind=", v%ind, " and v%a=", v%a, v%b%ch
print *
print *, "will assign v = x (other class)"
v = x
print *
print *, "after: v = , now v%ind=", v%ind, " and v%a=", v%a, v%b%ch
if ( v%a /= m ) error stop 1
if ( trim(v%b%ch) /= "_______________Hello" ) error stop 2
print *, "-----------------"
print *, "exiting s() ..."
end subroutine s
program test
use testmode
implicit none
call s()
print *, "finalized=", finalized, ", expected= 3"
if ( finalized /= 3 ) error stop
end program test
! { dg-do run }
! Test reallocation of an unlimited polymorphic scalar
! LHS with an allocatable component.
!
module testmode
implicit none
integer, public, save :: finalized = 0
integer, public, save :: counting = 0
type :: d0
integer :: ind
contains
final :: destruct0
end type d0
type, extends(d0) :: d1
integer :: i
end type d1
type, extends(d0) :: d2
integer :: j
class(d0), allocatable :: u
end type d2
contains
subroutine destruct0(self)
type(d0), intent(inout) :: self
if ( counting > 0 ) then
print *, "d0 % destruct1(self): ind=", self%ind
finalized = finalized + 1;
end if
end subroutine destruct0
end module testmode
subroutine s
use testmode
implicit none
class(d1), allocatable :: x
class(*), allocatable :: v
type(d0), save :: allocatable = d0(1000)
print *, "Initializing..."
allocate ( x , source = d1(1,1))
print *, "allocated x = d1(1,1)"
allocate ( v , source = d2(2,2,allocatable))
print *, "allocated v = d2(2,2,allocatable=1000)"
! Reset this as we test only intrinsic assignments
finalized = 0
counting = 1
print *, "set finalized=0"
print *
print *, "-----------------"
print *, "will assign v = x (other class)"
v = x
select type (v)
class is (d1)
print *, "assined v = x, now v%ind=", v%ind
class default
error stop 1
end select
print *
print *, "-----------------"
print *, "exiting s() ..."
end subroutine s
program test
use testmode
implicit none
call s()
print *, "finalized=", finalized, ", expected= 4"
if ( finalized /= 4 ) error stop 2
end program test
! { dg-do run }
! Test intrinsic assignment of a scalar LHS with
! an allocatable component that doesn't reallocate.
module testmode
implicit none
integer, public, save :: finalized = 0
integer, public, save :: counting = 0
type :: d0
integer :: ind
contains
final :: destruct0
end type d0
type, extends(d0) :: d1
integer :: i
end type d1
type, extends(d0) :: d2
integer :: j
class(d0), allocatable :: u
end type d2
contains
subroutine destruct0(self)
type(d0), intent(inout) :: self
if ( counting > 0 ) then
print *, "d0 % destruct1(self): ind=", self%ind
finalized = finalized + 1;
end if
end subroutine destruct0
end module testmode
subroutine s
use testmode
implicit none
class(d2), allocatable :: x
class(d2), allocatable :: v
type(d0), save :: allocatable1 = d0(1000)
type(d0), save :: allocatable2 = d0(2000)
print *, "Initializing..."
allocate ( x , source = d2(1,1,allocatable1))
print *, "allocated x = d2(1,1,allocatable1=1000)"
allocate ( v , source = d2(2,2,allocatable2))
print *, "allocated v = d2(2,2,allocatable2=2000)"
! Reset this as we test only intrinsic assignments
finalized = 0
counting = 1
print *, "set finalized=0"
print *
print *, "-----------------"
print *, "will assign v = x (same class - different components)"
v = x
print *, "assined v = x, now v%ind=", v%ind
print *
print *, "-----------------"
print *, "exiting s() ..."
end subroutine s
program test
use testmode
implicit none
call s()
print *, "finalized=", finalized, ", expected= 4"
if ( finalized /= 4 ) error stop
end program test
! { dg-do run }
!
! Test reallocation as demonstrated in F2018, 10.2.1.3
! for deferred chars with subroutine DEFERRED_LENGTH
!
! Also test the case that the NAME has a fixed length
! with subroutine FIXED_LENGTH
SUBROUTINE DEFERRED_LENGTH()
CLASS(*), ALLOCATABLE :: USER
CHARACTER(:),ALLOCATABLE :: NAME
CHARACTER(:),ALLOCATABLE :: FIRST_NAME
CHARACTER(:),ALLOCATABLE :: SURNAME
USER = 'NONE'
NAME = 'NONE'
PRINT *
PRINT *, "DEFERRED LENGTH NAME"
! Print Values & Compare
PRINT *
PRINT *, "NAME=", NAME, " [LEN=", LEN(NAME), "]"
SELECT TYPE (USER)
TYPE IS (CHARACTER(*))
PRINT *, "USER=", USER, " [LEN=", LEN(USER), "]"
IF ( LEN(USER) /= LEN(NAME) ) STOP 1
IF ( LEN(USER) /= 4 ) STOP 2
IF ( USER /= NAME ) STOP 3
END SELECT
ALLOCATE( FIRST_NAME , SOURCE = 'John Richard' )
ALLOCATE( SURNAME , SOURCE = 'Doe' )
USER = 'Mr. '//FIRST_NAME//' '//SURNAME
NAME = 'Mr. '//FIRST_NAME//' '//SURNAME
! Print Values & Compare
PRINT *
PRINT *, "NAME=", NAME, " [LEN=", LEN(NAME), "]"
SELECT TYPE (USER)
TYPE IS (CHARACTER(*))
PRINT *, "USER=", USER, " [LEN=", LEN(USER), "]"
IF ( LEN(USER) /= LEN(NAME) ) STOP 4
IF ( LEN(USER) /= 20 ) STOP 5
IF ( USER /= NAME ) STOP 6
END SELECT
USER = SURNAME
NAME = SURNAME
! Print Values & Compare
PRINT *
PRINT *, "NAME=", NAME, " [LEN=", LEN(NAME), "]"
SELECT TYPE (USER)
TYPE IS (CHARACTER(*))
PRINT *, "USER=", USER, " [LEN=", LEN(USER), "]"
IF ( LEN(USER) /= LEN(NAME) ) STOP 7
IF ( LEN(USER) /= 3 ) STOP 8
IF ( USER /= NAME ) STOP 9
END SELECT
END SUBROUTINE DEFERRED_LENGTH
SUBROUTINE FIXED_LENGTH()
CLASS(*), ALLOCATABLE :: USER
CHARACTER(15),ALLOCATABLE :: NAME
CHARACTER(:), ALLOCATABLE :: FIRST_NAME
CHARACTER(:), ALLOCATABLE :: SURNAME
PRINT *
PRINT *, "FIXED LENGTH NAME"
NAME = 'NONE'
USER = NAME
! Print Values & Compare
PRINT *
PRINT *, "NAME=", NAME, " [LEN=", LEN(NAME), "]"
SELECT TYPE (USER)
TYPE IS (CHARACTER(*))
PRINT *, "USER=", USER, " [LEN=", LEN(USER), "]"
IF ( LEN(USER) /= LEN(NAME) ) STOP 11
IF ( LEN(USER) /= 15 ) STOP 12
IF ( USER /= NAME ) STOP 13
END SELECT
ALLOCATE( FIRST_NAME , SOURCE = 'John Richard' )
ALLOCATE( SURNAME , SOURCE = 'Roe' )
NAME = 'Mr. '//FIRST_NAME//' '//SURNAME
USER = NAME
! Print Values & Compare
PRINT *
PRINT *, "NAME=", NAME, " [LEN=", LEN(NAME), "]"
SELECT TYPE (USER)
TYPE IS (CHARACTER(*))
PRINT *, "USER=", USER, " [LEN=", LEN(USER), "]"
IF ( LEN(USER) /= LEN(NAME) ) STOP 14
IF ( LEN(USER) /= 15 ) STOP 15
IF ( USER /= NAME ) STOP 16
END SELECT
NAME = SURNAME
USER = NAME
! Print Values & Compare
PRINT *
PRINT *, "NAME=", NAME, " [LEN=", LEN(NAME), "]"
SELECT TYPE (USER)
TYPE IS (CHARACTER(*))
PRINT *, "USER=", USER, " [LEN=", LEN(USER), "]"
IF ( LEN(USER) /= LEN(NAME) ) STOP 17
IF ( LEN(USER) /= 15 ) STOP 18
IF ( USER /= NAME ) STOP 19
END SELECT
END SUBROUTINE FIXED_LENGTH
CALL DEFERRED_LENGTH()
CALL FIXED_LENGTH()
PRINT *
END
! { dg-do run }
! Test intrinsic assignment of a scalar LHS with
! an allocatable component that doesn't reallocate,
! because it's not polymorphic.
module testmode
implicit none
integer, public, save :: finalized = 0
integer, public, save :: counting = 0
type :: d0
integer :: ind
contains
final :: destruct0
end type d0
type, extends(d0) :: d1
integer :: i
end type d1
type, extends(d0) :: d2
integer :: j
class(d0), allocatable :: u
end type d2
contains
subroutine destruct0(self)
type(d0), intent(inout) :: self
if ( counting > 0 ) then
print *, "d0 % destruct1(self): ind=", self%ind
finalized = finalized + 1;
end if
end subroutine destruct0
end module testmode
subroutine s
use testmode
implicit none
class(d2), allocatable :: x
type(d2), allocatable :: v,w
type(d0), save :: allocatable1 = d0(1000)
type(d0), save :: allocatable2 = d0(2000)
print *, "Initializing..."
allocate ( x , source = d2(1,1,allocatable1))
print *, "allocated x = d2(1,1,allocatable1=1000)"
allocate ( v , source = d2(2,2,allocatable2))
print *, "allocated v = d2(2,2,allocatable2=2000)"
allocate ( w , source = d2(3,3,allocatable2))
print *, "allocated w = d2(3,3,allocatable2=3000)"
! Reset this as we test only intrinsic assignments
finalized = 0
counting = 1
print *, "set finalized=0"
print *
print *, "-----------------"
print *, "will assign v = x (same class - different components)"
v = x
print *, "assined v = x, now v%ind=", v%ind, "allocated=", allocated(v)
print *
print *, "will assign v = w (same type - non poly assignment)"
v = w
print *, "assined v = w, now v%ind=", v%ind, "allocated=", allocated(v)
print *, "-----------------"
print *, "exiting s() ..."
end subroutine s
program test
use testmode
implicit none
call s()
print *, "finalized=", finalized, ", expected= 6"
if ( finalized /= 6 ) error stop
end program test
@drikosev
Copy link
Author

One may test any example from realloc_class_1.f90 to realloc_class_8.f95

As the example realloc_class_0.f90 attempts to catch a runtime error, so
testing it with a compiler other than my gfortran-4.8.5 may be pointless.

The example realloc_class_9.f90 has a non polymorphic assignment that
turned to be out of scope at the moment, where gfortran makes a
deallocation, invalid as I was informed.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment