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
|
! { dg-do run }
!
! Tests the fix for PR85603.
!
! Contributed by Walt Spector <w6ws@earthlink.net>
!_____________________________________________
! Module for a test against a regression that occurred with
! the first patch for this PR.
!
MODULE TN4
IMPLICIT NONE
PRIVATE
INTEGER,PARAMETER::SH4=KIND('a')
TYPE,PUBLIC::TOP
CHARACTER(:,KIND=SH4),ALLOCATABLE::ROR
CHARACTER(:,KIND=SH4),ALLOCATABLE::VI8
CONTAINS
PROCEDURE,NON_OVERRIDABLE::SB=>TPX
END TYPE TOP
CONTAINS
SUBROUTINE TPX(TP6,PP4)
CLASS(TOP),INTENT(INOUT)::TP6
INTEGER,INTENT(IN)::PP4
TP6%ROR=TP6%ROR(:PP4-1)
TP6%VI8=TP6%ROR(:PP4-1)
END SUBROUTINE TPX
END MODULE TN4
!_____________________________________________
!
program strlen_bug
implicit none
character(:), allocatable :: strings(:)
integer :: maxlen
strings = [ character(32) :: &
'short', &
'somewhat longer' ]
maxlen = maxval (len_trim (strings))
if (maxlen .ne. 15) stop 1
! Used to cause an ICE and in the later version of the problem did not reallocate.
strings = strings(:)(:maxlen)
if (any (strings .ne. ['short ','somewhat longer' ])) stop 2
if (len (strings) .ne. maxlen) stop 3
! Try something a bit more complicated.
strings = strings(:)(2:maxlen - 5)
if (any (strings .ne. ['hort ','omewhat l' ])) stop 4
if (len (strings) .ne. maxlen - 6) stop 5
deallocate (strings) ! To check for memory leaks
! Test the regression, noted by Dominique d'Humieres is fixed.
! Referenced in https://groups.google.com/forum/#!topic/comp.lang.fortran/nV3TlRlVKBc
!
call foo
contains
subroutine foo
USE TN4
TYPE(TOP) :: Z
Z%ROR = 'abcd'
call Z%SB (3)
if (Z%VI8 .ne. 'ab') stop 6
end
end program
|
