Deallocations on Intrinsic Assignment

realloc_class_0.f90

! { 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

realloc_class_1.f90

! { 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

realloc_class_2.f90

! { 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

realloc_class_3.f90

! { 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

realloc_class_4.f90

! { 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

realloc_class_4.f95

! { 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

realloc_class_5.f90

! { 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
    

realloc_class_5.f90.run.1.txt

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$ 

realloc_class_5.f90.run.5.txt

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$ 

realloc_class_6.f90

! { 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

realloc_class_6.f95

! { 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

realloc_class_7.f90

! { 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

realloc_class_8.f90

! { 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

realloc_class_8.f95

! { 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

realloc_class_9.f90

! { 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

I'd like to figure out what these two programs should print:
realloc_final_8.f90
realloc_final_9.f90

Also, I'd like to figure if all examples are valid Fortran programs.

[Files Renamed]

I'd like to figure out what these two programs should print:
realloc_class_8.f90
realloc_class_9.f90

Also, I'd like to figure out if all examples are valid Fortran programs.

The example realloc_class_6.f90 is perhaps invalid. Just in case, I'll change this:
class(d2), allocatable :: v
to:
class(d0), allocatable :: v

Also changed:
class(d2), allocatable :: v
to
class(d0), allocatable :: v

in realloc_class_4.f90 &
realloc_class_4.f95

Having some feedback, fixed the expected result (was '?') in:
realloc_class_8.f90 [expected=4]
realloc_class_9.f90 [expected=6]

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.