gcc/testsuite/gfortran.dg/deferred_character_8.f90

   1 ! { dg-do run }
   2 !
   3 ! Test the fix for all the remaining issues in PR54070. These were all
   4 ! concerned with deferred length characters being returned as function results,
   5 ! except for comment #23 where the descriptor dtype was not correctly set and
   6 ! array IO failed in consequence.
   7 !
   8 ! Contributed by Tobias Burnus  <burnus@gcc.gnu.org>
   9 !
  10 ! The original comment #1 with an allocate statement.
  11 ! Allocatable, deferred length scalar resul.
  12 function f()
  13   character(len=:),allocatable :: f
  14   allocate (f, source = "abc")
  15   f ="ABC"
  16 end function
  17 !
  18 ! Allocatable, deferred length, explicit, array result
  19 function g(a) result (res)
  20   character(len=*) :: a(:)
  21   character(len (a)) :: b(size (a))
  22   character(len=:),allocatable :: res(:)
  23   integer :: i
  24   allocate (character(len(a)) :: res(2*size(a)))
  25   do i = 1, len (a)
  26     b(:)(i:i) = char (ichar (a(:)(i:i)) + 4)
  27   end do
  28   res = [a, b]
  29 end function
  30 !
  31 ! Allocatable, deferred length, array result
  32 function h(a)
  33   character(len=*) :: a(:)
  34   character(len(a)) :: b (size(a))
  35   character(len=:),allocatable :: h(:)
  36   integer :: i
  37   allocate (character(len(a)) :: h(size(a)))
  38   do i = 1, len (a)
  39     b(:)(i:i) = char (ichar (a(:)(i:i)) + 32)
  40   end do
  41   h = b
  42 end function
  43
  44 module deferred_length_char_array
  45 contains
  46   function return_string(argument)
  47     character(*) :: argument
  48     character(:), dimension(:), allocatable :: return_string
  49     allocate (character (len(argument)) :: return_string(2))
  50     return_string = argument
  51   end function
  52 end module
  53
  54   use deferred_length_char_array
  55   character(len=3) :: chr(3)
  56   character(:), pointer :: s(:)
  57   character(6) :: buffer
  58   interface
  59     function f()
  60       character(len=:),allocatable :: f
  61     end function
  62     function g(a) result(res)
  63       character(len=*) :: a(:)
  64       character(len=:),allocatable :: res(:)
  65     end function
  66     function h(a)
  67       character(len=*) :: a(:)
  68       character(len=:),allocatable :: h(:)
  69     end function
  70   end interface
  71
  72   if (f () .ne. "ABC") call abort
  73   if (any (g (["ab","cd"]) .ne. ["ab","cd","ef","gh"])) call abort
  74   chr = h (["ABC","DEF","GHI"])
  75   if (any (chr .ne. ["abc","def","ghi"])) call abort
  76   if (any (return_string ("abcdefg") .ne. ["abcdefg","abcdefg"])) call abort
  77
  78 ! Comment #23
  79   allocate(character(3)::s(2))
  80   s(1) = 'foo'
  81   s(2) = 'bar'
  82   write (buffer, '(2A3)') s
  83   if (buffer .ne. 'foobar') call abort
  84 end