gcc/testsuite/gfortran.dg/deferred_type_component_2.f90

   1 ! { dg-do run }
   2 !
   3 ! PR 51976: [F2003] Support deferred-length character components of derived types (allocatable string length)
   4 !
   5 ! Contributed by Tobias Burnus  <burnus@gcc.gnu.org>
   6
   7   type t
   8     character(len=:,kind=4), allocatable :: str_comp
   9     character(len=:,kind=4), allocatable :: str_comp1
  10   end type t
  11   type(t) :: x
  12   type(t), allocatable, dimension(:) :: array
  13
  14   ! Check scalars
  15   allocate (x%str_comp, source = 4_"abc")
  16   call check (x%str_comp, 4_"abc")
  17   deallocate (x%str_comp)
  18   allocate (x%str_comp, source = 4_"abcdefghijklmnop")
  19   call check (x%str_comp, 4_"abcdefghijklmnop")
  20   x%str_comp = 4_"xyz"
  21   call check (x%str_comp, 4_"xyz")
  22   x%str_comp = 4_"abcdefghijklmnop"
  23   x%str_comp1 = 4_"lmnopqrst"
  24   call foo (x%str_comp1, 4_"lmnopqrst")
  25   call bar (x, 4_"abcdefghijklmnop", 4_"lmnopqrst")
  26
  27   ! Check arrays and structure constructors
  28   allocate (array(2), source = [t(4_"abcedefg",4_"hi"), t(4_"jkl",4_"mnop")])
  29   call check (array(1)%str_comp, 4_"abcedefg")
  30   call check (array(1)%str_comp1, 4_"hi")
  31   call check (array(2)%str_comp, 4_"jkl")
  32   call check (array(2)%str_comp1, 4_"mnop")
  33   deallocate (array)
  34   allocate (array(3), source = [x, x, x])
  35   array(2)%str_comp = 4_"blooey"
  36   call bar (array(1), 4_"abcdefghijklmnop", 4_"lmnopqrst")
  37   call bar (array(2), 4_"blooey", 4_"lmnopqrst")
  38   call bar (array(3), 4_"abcdefghijklmnop", 4_"lmnopqrst")
  39
  40 contains
  41
  42   subroutine foo (chr1, chr2)
  43     character (len=*,kind=4) :: chr1, chr2
  44     call check (chr1, chr2)
  45   end subroutine
  46
  47   subroutine bar (a, chr1, chr2)
  48     character (len=*,kind=4) :: chr1, chr2
  49     type(t) :: a
  50     call check (a%str_comp, chr1)
  51     call check (a%str_comp1, chr2)
  52   end subroutine
  53
  54   subroutine check (chr1, chr2)
  55     character (len=*,kind=4) :: chr1, chr2
  56     if (len(chr1) .ne. len (chr2)) STOP 1
  57     if (chr1 .ne. chr2) STOP 2
  58   end subroutine
  59
  60 end