gcc/testsuite/gfortran.dg/PR95214.f90

   1 ! { dg-do run }
   2 !
   3 ! PR fortran/95214
   4 !
   5
   6 program chr_p
   7
   8   implicit none
   9
  10   integer, parameter :: u = 65
  11
  12   integer, parameter :: n = 26
  13
  14   character :: c(n)
  15   integer   :: i
  16
  17   c = [(achar(i), i=u,u+n-1)]
  18   call chr_s(c, c)
  19   call gfc_descriptor_c_char(c)
  20   call s1(c)
  21   call s1s_a(c)
  22   call s1s_b(c)
  23   call s2(c)
  24   stop
  25
  26 contains
  27
  28   subroutine chr_s(a, b)
  29     character, intent(in) :: a(..)
  30     character, intent(in) :: b(:)
  31
  32     integer :: i
  33
  34     select rank(a)
  35     rank(1)
  36       do i = 1, size(a)
  37         if(a(i)/=b(i)) stop 1
  38       end do
  39     rank default
  40       stop 2
  41     end select
  42     return
  43   end subroutine chr_s
  44
  45   ! From Bug 66833
  46   ! Contributed by Damian Rouson <damian@sourceryinstitute.org>
  47   subroutine gfc_descriptor_c_char(a)
  48     character a(..)
  49     if(rank(a)/=1) stop 3 ! ICE (also for lbound, ubound, and c_loc)
  50   end subroutine gfc_descriptor_c_char
  51
  52
  53   ! From Bug 67938
  54   ! Contributed by Gerhard Steinmetz <gerhard.steinmetz.fortran@t-online.de>
  55
  56   ! example z1.f90
  57   subroutine s1(x)
  58     character(1) :: x(..)
  59     if(any(lbound(x)/=[1])) stop 4
  60     if(any(ubound(x)/=[n])) stop 5
  61   end subroutine s1
  62
  63   ! example z1s.f90
  64   subroutine s1s_a(x)
  65     character :: x(..)
  66     if(size(x)/=n) stop 6
  67   end subroutine s1s_a
  68
  69   subroutine s1s_b(x)
  70     character(77) :: x(..)
  71     if(size(x)/=n) stop 7
  72   end subroutine s1s_b
  73
  74   ! example z2.f90
  75   subroutine s2(x)
  76     character(1) :: x(..)
  77     if(lbound(x, dim=1)/=1) stop 8
  78     if(ubound(x, dim=1)/=n) stop 9
  79     if(size(x, dim=1)/=n)   stop 10
  80   end subroutine s2
  81
  82 end program chr_p
  83
  84