gcc/testsuite/gfortran.dg/bind_c_char_9.f90

! { dg-do run }
! { dg-additional-options "-fdump-tree-original" }

! F2018  - examples without array descriptor


module m
  use iso_c_binding, only: c_char
  implicit none (type, external)

contains

! Scalar, nonallocatable/nonpointer
subroutine s1 (x1) bind(C)
  character(kind=c_char, len=1) :: x1
  if (len (x1) /= 1) stop
  if (x1 /= 'Z') stop
  x1 = 'A'
end

subroutine s2 (x2) bind(C)
  character(kind=c_char, len=2) :: x2
  if (len (x2) /= 2) stop
  if (x2 /= '42') stop
  x2 = '64'
end

! Assumed-size array, nonallocatable/nonpointer

subroutine az1 (x1) bind(C)
  character(kind=c_char, len=1) :: x1(*)
  if (len(x1) /= 1) stop  
  if (any (x1(:6) /= ['g', &
                      'd', &
                      'f', &
                      's', &
                      '3', &
                      '5'])) stop 1
  x1(:6) = ['1', &
            'h', &
            'f', &
            '3', &
            '4', &
            'h']
end

subroutine az2 (x2) bind(C)
  character(kind=c_char, len=2) :: x2(*)
  if (len(x2) /= 2) stop  
  if (any (x2(:6) /= ['ab', &
                      'fd', &
                      'D4', &
                      '54', &
                      'ga', &
                      'hg'])) stop
  x2(:6) = ['ab', &
            'hd', &
            'fj', &
            'a4', &
            '4a', &
            'hf']
end

! Explicit-size array, nonallocatable/nonpointer

subroutine ae1 (x1) bind(C)
  character(kind=c_char, len=1) :: x1(6)
  if (size(x1) /= 6) stop
  if (len(x1) /= 1) stop  
  if (any (x1 /= ['g', &
                  'd', &
                  'f', &
                  's', &
                  '3', &
                  '5'])) stop 1
  x1 = ['1', &
        'h', &
        'f', &
        '3', &
        '4', &
        'h']
end

subroutine ae2 (x2) bind(C)
  character(kind=c_char, len=2) :: x2(6)
  if (size(x2) /= 6) stop
  if (len(x2) /= 2) stop  
  if (any (x2 /= ['ab', &
                  'fd', &
                  'D4', &
                  '54', &
                  'ga', &
                  'hg'])) stop
  x2 = ['ab', &
        'hd', &
        'fj', &
        'a4', &
        '4a', &
        'hf']
end

end module m

program main
  use m
  implicit none (type, external)
  character(kind=c_char, len=1) :: str1
  character(kind=c_char, len=2) :: str2

  character(kind=c_char, len=1) :: str1a6(6)
  character(kind=c_char, len=2) :: str2a6(6)

  ! Scalar - no array descriptor

  str1 = 'Z'
  call s1 (str1)
  if (str1 /= 'A') stop

  str2 = '42'
  call s2 (str2)
  if (str2 /= '64') stop

  ! assumed size - without array descriptor

  str1a6 = ['g', &
            'd', &
            'f', &
            's', &
            '3', &
            '5']
  call az1 (str1a6)
  if (any (str1a6 /= ['1', &
                      'h', &
                      'f', &
                      '3', &
                      '4', &
                      'h'])) stop
  str2a6 = ['ab', &
            'fd', &
            'D4', &
            '54', &
            'ga', &
            'hg']
  call az2 (str2a6)
  if (any (str2a6 /= ['ab', &
                      'hd', &
                      'fj', &
                      'a4', &
                      '4a', &
                      'hf'])) stop
  ! explicit size - without array descriptor

  str1a6 = ['g', &
            'd', &
            'f', &
            's', &
            '3', &
            '5']
  call ae1 (str1a6)
  if (any (str1a6 /= ['1', &
                      'h', &
                      'f', &
                      '3', &
                      '4', &
                      'h'])) stop
  str2a6 = ['ab', &
            'fd', &
            'D4', &
            '54', &
            'ga', &
            'hg']
  call ae2 (str2a6)
  if (any (str2a6 /= ['ab', &
                      'hd', &
                      'fj', &
                      'a4', &
                      '4a', &
                      'hf'])) stop
end

! All argument shall be passed without descriptor
! { dg-final { scan-tree-dump-not "dtype" "original" } }
! { dg-final { scan-tree-dump-times "void s1 \\(character\\(kind=1\\)\\\[1:1\\\] & restrict x1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "void s2 \\(character\\(kind=1\\)\\\[1:2\\\] & restrict x2\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "void az1 \\(character\\(kind=1\\)\\\[0:\\\]\\\[1:1\\\] \\* restrict x1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "void az2 \\(character\\(kind=1\\)\\\[0:\\\]\\\[1:2\\\] \\* restrict x2\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "void ae1 \\(character\\(kind=1\\)\\\[6\\\]\\\[1:1\\\] \\* restrict x1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "void ae2 \\(character\\(kind=1\\)\\\[6\\\]\\\[1:2\\\] \\* restrict x2\\)" 1 "original" } }