gcc/testsuite/gfortran.dg/transfer_char_kind4.f90

   1 ! { dg-do run }
   2 ! PR fortran/83079 - ICE and wrong code with TRANSFER and character(kind=4)
   3 ! Exercise TRANSFER intrinsic to check character result length and shape
   4
   5 program p
   6   implicit none
   7   character(len=*,kind=4), parameter :: a = 4_'ABCDEF'
   8   character(len=6,kind=4)            :: b = 4_'abcdef'
   9   character(len=*,kind=4), parameter :: c = 4_'XY'
  10   character(len=2,kind=4)            :: d = 4_'xy'
  11   integer :: k, l
  12   k = len (a)
  13   l = len (c)
  14
  15 ! print *, transfer(4_'xy', [4_'a'])
  16
  17   ! TRANSFER with rank-0 result
  18   call chk0 (transfer (4_'ABCD', 4_'XY'), 2, 1)
  19   call chk0 (transfer (4_'ABCD', c     ), l, 2)
  20   call chk0 (transfer (4_'ABCD', d     ), l, 3)
  21   call chk0 (transfer (a       , 4_'XY'), 2, 4)
  22   call chk0 (transfer (a       , c     ), l, 5)
  23   call chk0 (transfer (a       , d     ), l, 6)
  24   call chk0 (transfer (b       , 4_'XY'), 2, 7)
  25   call chk0 (transfer (b       , c     ), l, 8)
  26   call chk0 (transfer (b       , d     ), l, 9)
  27
  28   call chk0 (transfer ([4_'ABCD'], 4_'XY'), 2, 11)
  29   call chk0 (transfer ([4_'ABCD'], c     ), l, 12)
  30   call chk0 (transfer ([4_'ABCD'], d     ), l, 13)
  31   call chk0 (transfer ([a       ], 4_'XY'), 2, 14)
  32   call chk0 (transfer ([a       ], c     ), l, 15)
  33   call chk0 (transfer ([a       ], d     ), l, 16)
  34   call chk0 (transfer ([b       ], 4_'XY'), 2, 17)
  35   call chk0 (transfer ([b       ], c     ), l, 18)
  36   call chk0 (transfer ([b       ], d     ), l, 19)
  37
  38   ! TRANSFER with rank-1 result
  39   call chk1 (transfer (4_'ABCD', [4_'XY']), 2,   2, 21)
  40   call chk1 (transfer (4_'ABCD', [c]     ), 2,   2, 22)
  41   call chk1 (transfer (4_'ABCD', [d]     ), 2,   2, 23)
  42   call chk1 (transfer (a       , [4_'XY']), 2, k/2, 24)
  43   call chk1 (transfer (a       , [c]     ), l, k/l, 25)
  44   call chk1 (transfer (a       , [d]     ), l, k/l, 26)
  45   call chk1 (transfer (b       , [4_'XY']), 2, k/2, 27)
  46   call chk1 (transfer (b       , [c]     ), l, k/l, 28)
  47   call chk1 (transfer (b       , [d]     ), l, k/l, 29)
  48
  49   call chk1 (transfer (4_'ABCD', 4_'XY',size=2), 2, 2, 31)
  50   call chk1 (transfer (4_'ABCD', c     ,size=2), 2, 2, 32)
  51   call chk1 (transfer (4_'ABCD', d     ,size=2), 2, 2, 33)
  52   call chk1 (transfer (a       , 4_'XY',size=3), 2, 3, 34)
  53   call chk1 (transfer (a       , c     ,size=3), l, 3, 35)
  54   call chk1 (transfer (a       , d     ,size=3), l, 3, 36)
  55   call chk1 (transfer (b       , 4_'XY',size=3), 2, 3, 37)
  56   call chk1 (transfer (b       , c     ,size=3), l, 3, 38)
  57   call chk1 (transfer (b       , d     ,size=3), l, 3, 39)
  58
  59   call chk1 (transfer (4_'ABCD', [4_'XY'],size=2), 2, 2, 41)
  60   call chk1 (transfer (4_'ABCD', [c]     ,size=2), 2, 2, 42)
  61   call chk1 (transfer (4_'ABCD', [d]     ,size=2), 2, 2, 43)
  62   call chk1 (transfer (a       , [4_'XY'],size=3), 2, 3, 44)
  63   call chk1 (transfer (a       , [c]     ,size=3), l, 3, 45)
  64   call chk1 (transfer (a       , [d]     ,size=3), l, 3, 46)
  65   call chk1 (transfer (b       , [4_'XY'],size=3), 2, 3, 47)
  66   call chk1 (transfer (b       , [c]     ,size=3), l, 3, 48)
  67   call chk1 (transfer (b       , [d]     ,size=3), l, 3, 49)
  68
  69   call chk1 (transfer ([4_'ABCD'], [4_'XY']), 2,   2, 51)
  70   call chk1 (transfer ([4_'ABCD'], [c]     ), 2,   2, 52)
  71   call chk1 (transfer ([4_'ABCD'], [d]     ), 2,   2, 53)
  72   call chk1 (transfer ([a       ], [4_'XY']), 2, k/2, 54)
  73   call chk1 (transfer ([a       ], [c]     ), l, k/l, 55)
  74   call chk1 (transfer ([a       ], [d]     ), l, k/l, 56)
  75   call chk1 (transfer ([b       ], [4_'XY']), 2, k/2, 57)
  76   call chk1 (transfer ([b       ], [c]     ), l, k/l, 58)
  77   call chk1 (transfer ([b       ], [d]     ), l, k/l, 59)
  78
  79   call chk1 (transfer (4_'ABCD', c     ,size=4/l), l, 4/l, 62)
  80   call chk1 (transfer (4_'ABCD', d     ,size=4/l), l, 4/l, 63)
  81   call chk1 (transfer (a       , 4_'XY',size=k/2), 2, k/2, 64)
  82   call chk1 (transfer (a       , c     ,size=k/l), l, k/l, 65)
  83   call chk1 (transfer (a       , d     ,size=k/l), l, k/l, 66)
  84   call chk1 (transfer (b       , 4_'XY',size=k/2), 2, k/2, 67)
  85   call chk1 (transfer (b       , c     ,size=k/l), l, k/l, 68)
  86   call chk1 (transfer (b       , d     ,size=k/l), l, k/l, 69)
  87
  88 contains
  89   ! Validate rank-0 result
  90   subroutine chk0 (str, l, stopcode)
  91     character(kind=4,len=*), intent(in) :: str
  92     integer,                 intent(in) :: l, stopcode
  93     integer :: i, p
  94     i = len  (str)
  95     p = verify (str, a // b) ! Check for junk characters
  96     if (i /= l .or. p > 0) then
  97        print *, stopcode, "len=", i, i == l, ">", str, "<"
  98        stop stopcode
  99     end if
 100   end subroutine chk0
 101
 102   ! Validate rank-1 result
 103   subroutine chk1 (str, l, m, stopcode)
 104     character(kind=4,len=*), intent(in) :: str(:)
 105     integer,                 intent(in) :: l, m, stopcode
 106     integer :: i, j, p
 107     i = len  (str)
 108     j = size (str)
 109     p = maxval (verify (str, a // b)) ! Check for junk characters
 110     if (i /= l .or. j /= m .or. p > 0) then
 111        print *, stopcode, "len=", i, i == l, "size=", j, j == m, ">", str, "<"
 112        stop stopcode
 113     end if
 114   end subroutine chk1
 115 end