1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
|
! { 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
|
