gcc/testsuite/gfortran.dg/ichar_1.f90

   1 ! { dg-do compile }
   2 ! { dg-options "-std=legacy" }
   3 !
   4 ! PR20879
   5 ! Check that we reject expressions longer than one character for the
   6 ! ICHAR and IACHAR intrinsics.
   7
   8 ! Assumed length variables are special because the frontend doesn't have
   9 ! an expression for their length
  10 subroutine test (c)
  11   character(len=*) :: c
  12   integer i
  13   i = ichar(c)
  14   i = ichar(c(2:))
  15   i = ichar(c(:1))
  16 end subroutine
  17
  18 program ichar_1
  19    type derivedtype
  20       character(len=4) :: addr
  21    end type derivedtype
  22
  23    type derivedtype1
  24       character(len=1) :: addr
  25    end type derivedtype1
  26
  27    integer i
  28    integer, parameter :: j = 2
  29    character(len=8) :: c = 'abcd'
  30    character(len=1) :: g1(2)
  31    character(len=1) :: g2(2,2)
  32    character*1, parameter :: s1 = 'e'
  33    character*2, parameter :: s2 = 'ef'
  34    type(derivedtype) :: dt
  35    type(derivedtype1) :: dt1
  36
  37    if (ichar(c(3:3)) /= 97) call abort
  38    if (ichar(c(:1)) /= 97) call abort
  39    if (ichar(c(j:j)) /= 98) call abort
  40    if (ichar(s1) /= 101) call abort
  41    if (ichar('f') /= 102) call abort
  42    g1(1) = 'a'
  43    if (ichar(g1(1)) /= 97) call abort
  44    if (ichar(g1(1)(:)) /= 97) call abort
  45    g2(1,1) = 'a'
  46    if (ichar(g2(1,1)) /= 97) call abort
  47
  48    i = ichar(c)      ! { dg-error "must be of length one" "" }
  49    i = ichar(c(:))   ! { dg-error "must be of length one" "" }
  50    i = ichar(s2)     ! { dg-error "must be of length one" "" }
  51    i = ichar(c(1:2)) ! { dg-error "must be of length one" "" }
  52    i = ichar(c(1:))  ! { dg-error "must be of length one" "" }
  53    i = ichar('abc')  ! { dg-error "must be of length one" "" }
  54
  55    ! ichar and iachar use the same checking routines. DO a couple of tests to
  56    ! make sure it's not totally broken.
  57
  58    if (ichar(c(3:3)) /= 97) call abort
  59    i = ichar(c)      ! { dg-error "must be of length one" "" }
  60
  61    i = ichar(dt%addr(1:1))
  62    i = ichar(dt%addr) ! { dg-error "must be of length one" "" }
  63    i = ichar(dt%addr(1:2)) ! { dg-error "must be of length one" "" }
  64    i = ichar(dt%addr(1:)) ! { dg-error "must be of length one" "" }
  65
  66    i = ichar(dt1%addr(1:1))
  67    i = ichar(dt1%addr)
  68
  69
  70    call test(g1(1))
  71 end program ichar_1