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