Last active
January 19, 2021 09:50
-
-
Save drikosev/a9e9e8357dbc45aeb02773198069222b to your computer and use it in GitHub Desktop.
Deallocations on Intrinsic Assignment
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
! { 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 | |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
! { 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 | |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
! { 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 | |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
! { 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 | |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
! { 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 | |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
! { 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 | |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
! { 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 | |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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$ |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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$ |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
! { 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 | |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
! { 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 | |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
! { 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 | |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
! { 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 | |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
! { 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 | |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
! { 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 | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
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.