gcc/testsuite/gfortran.dg/deferred_character_37.f90

   1 ! { dg-do run }
   2 ! PR fortran/95947
   3 ! PR fortran/110658
   4 !
   5 ! Test deferred-length character arguments to selected intrinsics
   6 ! that may return a character result of same length as first argument:
   7 ! CSHIFT, EOSHIFT, MAXVAL, MERGE, MINVAL, PACK, SPREAD, TRANSPOSE, UNPACK
   8
   9 program p
  10   implicit none
  11   call pr95947 ()
  12   call pr110658 ()
  13   call s ()
  14
  15 contains
  16
  17   subroutine pr95947
  18     character(len=:), allocatable :: m(:)
  19
  20     m = [ character(len=10) :: 'ape','bat','cat','dog','eel','fly','gnu']
  21     m = pack (m, mask=(m(:)(2:2) == 'a'))
  22
  23 !   print *, "m = '", m,"' ",               "; expected is ['bat','cat']"
  24     if (.not. all (m == ['bat','cat'])) stop 1
  25
  26 !   print *, "size(m) =     ", size(m),     "; expected is 2"
  27     if (size (m) /= 2) stop 2
  28
  29 !   print *, "len(m) =      ", len(m),      "; expected is 10"
  30     if (len (m) /= 10) stop 3
  31
  32 !   print *, "len_trim(m) = ", len_trim(m), "; expected is 3 3"
  33     if (.not. all (len_trim(m) == [3,3])) stop 4
  34   end
  35
  36   subroutine pr110658
  37     character(len=:), allocatable :: array(:), array2(:,:)
  38     character(len=:), allocatable :: res, res1(:), res2(:)
  39
  40     array = ["bb", "aa", "cc"]
  41
  42     res = minval (array)
  43     if (res /= "aa") stop 11
  44
  45     res = maxval (array, mask=[.true.,.true.,.false.])
  46     if (res /= "bb") stop 12
  47
  48     res1 = cshift (array, 1)
  49     if (any (res1 /= ["aa","cc","bb"])) stop 13
  50
  51     res2 = eoshift (res1, -1)
  52     if (any (res2 /= ["  ", "aa", "cc"])) stop 14
  53
  54     res2 = pack (array, mask=[.true.,.false.,.true.])
  55     if (any (res2 /= ["bb","cc"])) stop 15
  56
  57     res2 = unpack (res2, mask=[.true.,.false.,.true.], field="aa")
  58     if (any (res2 /= array)) stop 16
  59
  60     res2 = merge (res2, array, [.true.,.false.,.true.])
  61     if (any (res2 /= array)) stop 17
  62
  63     array2 = spread (array, dim=2, ncopies=2)
  64     array2 = transpose (array2)
  65     if (any (shape (array2) /= [2,3])) stop 18
  66     if (any (array2(2,:) /= array))    stop 19
  67   end
  68
  69   subroutine s
  70     character(:), allocatable :: array1(:), array2(:)
  71     array1 = ["aa","cc","bb"]
  72     array2 = copy (array1)
  73     if (any (array1 /= array2)) stop 20
  74   end
  75
  76   function copy (arg) result (res)
  77     character(:), allocatable :: res(:)
  78     character(*), intent(in)  :: arg(:)
  79     integer :: i, k, n
  80     k = len (arg)
  81     n = size (arg)
  82     allocate (character(k) :: res(n))
  83     do i = 1, n
  84        res(i) = arg(i)
  85     end do
  86   end
  87
  88 end