gcc/testsuite/gfortran.dg/deferred_character_23.f90

   1 ! { dg-do run }
   2 !
   3 ! Tests the fix for PR85603.
   4 !
   5 ! Contributed by Walt Spector  <w6ws@earthlink.net>
   6 !_____________________________________________
   7 ! Module for a test against a regression that occurred with
   8 ! the first patch for this PR.
   9 !
  10 MODULE TN4
  11   IMPLICIT NONE
  12   PRIVATE
  13   INTEGER,PARAMETER::SH4=KIND('a')
  14   TYPE,PUBLIC::TOP
  15     CHARACTER(:,KIND=SH4),ALLOCATABLE::ROR
  16     CHARACTER(:,KIND=SH4),ALLOCATABLE::VI8
  17   CONTAINS
  18     PROCEDURE,NON_OVERRIDABLE::SB=>TPX
  19   END TYPE TOP
  20 CONTAINS
  21   SUBROUTINE TPX(TP6,PP4)
  22     CLASS(TOP),INTENT(INOUT)::TP6
  23     INTEGER,INTENT(IN)::PP4
  24     TP6%ROR=TP6%ROR(:PP4-1)
  25     TP6%VI8=TP6%ROR(:PP4-1)
  26   END SUBROUTINE TPX
  27 END MODULE TN4
  28 !_____________________________________________
  29 !
  30 program strlen_bug
  31   implicit none
  32
  33   character(:), allocatable :: strings(:)
  34   integer :: maxlen
  35
  36   strings = [ character(32) ::  &
  37       'short',  &
  38       'somewhat longer' ]
  39   maxlen = maxval (len_trim (strings))
  40   if (maxlen .ne. 15) stop 1
  41
  42 ! Used to cause an ICE and in the later version of the problem did not reallocate.
  43   strings = strings(:)(:maxlen)
  44   if (any (strings .ne. ['short          ','somewhat longer' ])) stop 2
  45   if (len (strings) .ne. maxlen) stop 3
  46
  47 ! Try something a bit more complicated.
  48   strings = strings(:)(2:maxlen - 5)
  49   if (any (strings .ne. ['hort     ','omewhat l' ])) stop 4
  50   if (len (strings) .ne. maxlen - 6) stop 5
  51
  52   deallocate (strings)          ! To check for memory leaks
  53
  54 ! Test the regression, noted by Dominique d'Humieres is fixed.
  55 ! Referenced in https://groups.google.com/forum/#!topic/comp.lang.fortran/nV3TlRlVKBc
  56 !
  57   call foo
  58 contains
  59   subroutine foo
  60     USE TN4
  61     TYPE(TOP) :: Z
  62
  63     Z%ROR = 'abcd'
  64     call Z%SB (3)
  65     if (Z%VI8 .ne. 'ab') stop 6
  66 end
  67
  68 end program