gcc/testsuite/gfortran.dg/allocatable_length_2.f90

   1 ! { dg-do run }
   2 ! PR fortran/113911
   3 !
   4 ! Test that deferred length is not lost
   5
   6 module m
   7   integer, parameter        :: n = 100, l = 10
   8   character(l)              :: a = 'a234567890', b(n) = 'bcdefghijk'
   9   character(:), allocatable :: c1, c2(:)
  10 end
  11
  12 program p
  13   use m, only : l, n, a, b, x => c1, y => c2
  14   implicit none
  15   character(:), allocatable :: d, e(:)
  16   allocate (d, source=a)
  17   allocate (e, source=b)
  18   if (len (d) /= l .or. len (e) /= l .or. size (e) /= n) stop 12
  19   call plain_deferred (d, e)
  20   call optional_deferred (d, e)
  21   call optional_deferred_ar (d, e)
  22   if (len (d) /= l .or. len (e) /= l .or. size (e) /= n) stop 13
  23   deallocate (d, e)
  24   call alloc (d, e)
  25   if (len (d) /= l .or. len (e) /= l .or. size (e) /= n) stop 14
  26   deallocate (d, e)
  27   call alloc_host_assoc ()
  28   if (len (d) /= l .or. len (e) /= l .or. size (e) /= n) stop 15
  29   deallocate (d, e)
  30   call alloc_use_assoc ()
  31   if (len (x) /= l .or. len (y) /= l .or. size (y) /= n) stop 16
  32   call indirect (x, y)
  33   if (len (x) /= l .or. len (y) /= l .or. size (y) /= n) stop 17
  34   deallocate (x, y)
  35 contains
  36   subroutine plain_deferred (c1, c2)
  37     character(:), allocatable :: c1, c2(:)
  38     if (.not. allocated (c1) .or. .not. allocated (c2)) stop 1
  39     if (len (c1) /= l) stop 2
  40     if (len (c2) /= l) stop 3
  41     if (c1(1:3)    /= "a23") stop 4
  42     if (c2(5)(1:3) /= "bcd") stop 5
  43   end
  44
  45   subroutine optional_deferred (c1, c2)
  46     character(:), allocatable, optional :: c1, c2(:)
  47     if (.not. present   (c1) .or. .not. present   (c2)) stop 6
  48     if (.not. allocated (c1) .or. .not. allocated (c2)) stop 7
  49     if (len (c1) /= l) stop 8
  50     if (len (c2) /= l) stop 9
  51     if (c1(1:3)    /= "a23") stop 10
  52     if (c2(5)(1:3) /= "bcd") stop 11
  53   end
  54
  55   ! Assumed rank
  56   subroutine optional_deferred_ar (c1, c2)
  57     character(:), allocatable, optional :: c1(..)
  58     character(:), allocatable, optional :: c2(..)
  59     if (.not. present   (c1) .or. &
  60         .not. present   (c2)) stop 21
  61     if (.not. allocated (c1) .or. &
  62         .not. allocated (c2)) stop 22
  63
  64     select rank (c1)
  65     rank (0)
  66     if (len (c1) /= l)       stop 23
  67       if (c1(1:3)  /= "a23") stop 24
  68     rank default
  69       stop 25
  70     end select
  71
  72     select rank (c2)
  73     rank (1)
  74       if (len (c2) /= l)       stop 26
  75       if (c2(5)(1:3) /= "bcd") stop 27
  76     rank default
  77       stop 28
  78     end select
  79   end
  80
  81   ! Allocate dummy arguments
  82   subroutine alloc (c1, c2)
  83     character(:), allocatable :: c1, c2(:)
  84     allocate (c1, source=a)
  85     allocate (c2, source=b)
  86   end
  87
  88   ! Allocate host-associated variables
  89   subroutine alloc_host_assoc ()
  90     allocate (d, source=a)
  91     allocate (e, source=b)
  92   end
  93
  94   ! Allocate use-associated variables
  95   subroutine alloc_use_assoc ()
  96     allocate (x, source=a)
  97     allocate (y, source=b)
  98   end
  99
 100   ! Pass-through deferred-length
 101   subroutine indirect (c1, c2)
 102     character(:), allocatable :: c1, c2(:)
 103     call plain_deferred (c1, c2)
 104     call optional_deferred (c1, c2)
 105     call optional_deferred_ar (c1, c2)
 106   end
 107 end