mirror of
https://github.com/autc04/Retro68.git
synced 2024-06-28 11:30:19 +00:00
72 lines
2.0 KiB
Fortran
72 lines
2.0 KiB
Fortran
! { dg-do run }
|
|
!
|
|
! Test the fix for PR87151 by exercising deferred length character
|
|
! array components.
|
|
!
|
|
! Based on the contribution by Valery Weber <valeryweber@hotmail.com>
|
|
!
|
|
module bvec
|
|
type, public :: bvec_t
|
|
private
|
|
character(:), dimension(:), allocatable :: vc
|
|
contains
|
|
PROCEDURE, PASS :: create
|
|
PROCEDURE, PASS :: test_bvec
|
|
PROCEDURE, PASS :: delete
|
|
end type bvec_t
|
|
contains
|
|
subroutine create (this, switch)
|
|
class(bvec_t), intent(inout) :: this
|
|
logical :: switch
|
|
if (switch) then
|
|
allocate (character(2)::this%vc(3))
|
|
if (len (this%vc) .ne. 2) stop 1 ! The orignal problem. Gave 0.
|
|
|
|
! Check that reallocation on assign does what it should do as required by
|
|
! F2003 7.4.1.3. ie. reallocation occurs because LEN has changed.
|
|
this%vc = ['abcd','efgh','ijkl']
|
|
else
|
|
allocate (this%vc, source = ['abcd','efgh','ijkl'])
|
|
endif
|
|
end subroutine create
|
|
|
|
subroutine test_bvec (this)
|
|
class(bvec_t), intent(inout) :: this
|
|
character(20) :: buffer
|
|
if (allocated (this%vc)) then
|
|
if (len (this%vc) .ne. 4) stop 2
|
|
if (size (this%vc) .ne. 3) stop 3
|
|
! Check array referencing and scalarized array referencing
|
|
if (this%vc(2) .ne. 'efgh') stop 4
|
|
if (any (this%vc .ne. ['abcd','efgh','ijkl'])) stop 5
|
|
! Check full array io
|
|
write (buffer, *) this%vc
|
|
if (trim (buffer(2:)) .ne. 'abcdefghijkl') stop 6
|
|
! Make sure that substrings work correctly
|
|
write (buffer, *) this%vc(:)(2:3)
|
|
if (trim (buffer(2:)) .ne. 'bcfgjk') stop 7
|
|
write (buffer, *) this%vc(2:)(2:3)
|
|
if (trim (buffer(2:)) .ne. 'fgjk') stop 8
|
|
endif
|
|
end subroutine test_bvec
|
|
|
|
subroutine delete (this)
|
|
class(bvec_t), intent(inout) :: this
|
|
if (allocated (this%vc)) then
|
|
deallocate (this%vc)
|
|
endif
|
|
end subroutine delete
|
|
end module bvec
|
|
|
|
program test
|
|
use bvec
|
|
type(bvec_t) :: a
|
|
call a%create (.false.)
|
|
call a%test_bvec
|
|
call a%delete
|
|
|
|
call a%create (.true.)
|
|
call a%test_bvec
|
|
call a%delete
|
|
end program test
|