gcc/testsuite/gfortran.dg/bind_c_optional-2.f90

   1 ! { dg-do run }
   2 ! PR fortran/113866
   3 !
   4 ! Check interoperability of assumed-length character (optional and
   5 ! non-optional) dummies between bind(c) and non-bind(c) procedures
   6
   7 module bindcchar
   8   implicit none
   9   integer, parameter :: n = 100, l = 10
  10 contains
  11   subroutine bindc_optional (c2, c4) bind(c)
  12     character(*), optional :: c2, c4(n)
  13 !   print *, c2(1:3)
  14 !   print *, c4(5)(1:3)
  15     if (.not. present (c2) .or. .not. present (c4)) stop 8
  16     if (len (c2) /= l .or. len (c4) /= l) stop 81
  17     if (c2(1:3)    /= "a23") stop 1
  18     if (c4(5)(1:3) /= "bcd") stop 2
  19   end
  20
  21   subroutine bindc (c2, c4) bind(c)
  22     character(*) :: c2, c4(n)
  23     if (len (c2) /= l .or. len (c4) /= l) stop 82
  24     if (c2(1:3)    /= "a23") stop 3
  25     if (c4(5)(1:3) /= "bcd") stop 4
  26     call bindc_optional (c2, c4)
  27   end
  28
  29   subroutine not_bindc_optional (c1, c3)
  30     character(*), optional :: c1, c3(n)
  31     if (.not. present (c1) .or. .not. present (c3)) stop 5
  32     if (len (c1) /= l .or. len (c3) /= l) stop 83
  33     call bindc_optional (c1, c3)
  34     call bindc          (c1, c3)
  35   end
  36
  37   subroutine not_bindc_optional_deferred (c5, c6)
  38     character(:), allocatable, optional :: c5, c6(:)
  39     if (.not. present (c5) .or. .not. present (c6)) stop 6
  40     if (len (c5) /= l .or. len (c6) /= l) stop 84
  41     call not_bindc_optional (c5, c6)
  42     call bindc_optional     (c5, c6)
  43     call bindc              (c5, c6)
  44   end
  45
  46   subroutine not_bindc_optional2 (c7, c8)
  47     character(*), optional :: c7, c8(:)
  48     if (.not. present (c7) .or. .not. present (c8)) stop 7
  49     if (len (c7) /= l .or. len (c8) /= l) stop 85
  50     call bindc_optional (c7, c8)
  51     call bindc          (c7, c8)
  52   end
  53
  54   subroutine bindc_optional2 (c2, c4) bind(c)
  55     character(*), optional :: c2, c4(n)
  56     if (.not. present (c2) .or. .not. present (c4)) stop 8
  57     if (len (c2) /= l .or. len (c4) /= l) stop 86
  58     if (c2(1:3)    /= "a23") stop 9
  59     if (c4(5)(1:3) /= "bcd") stop 10
  60     call bindc_optional     (c2, c4)
  61     call not_bindc_optional (c2, c4)
  62   end
  63
  64   subroutine bindc_optional_missing (c1, c2, c3, c4, c5) bind(c)
  65     character(*), optional :: c1, c2(n), c3(:), c4(..), c5(*)
  66     if (present (c1)) stop 11
  67     if (present (c2)) stop 12
  68     if (present (c3)) stop 13
  69     if (present (c4)) stop 14
  70     if (present (c5)) stop 15
  71   end
  72
  73   subroutine non_bindc_optional_missing (c1, c2, c3, c4, c5)
  74     character(*), optional :: c1, c2(n), c3(:), c4(..), c5(*)
  75     if (present (c1)) stop 21
  76     if (present (c2)) stop 22
  77     if (present (c3)) stop 23
  78     if (present (c4)) stop 24
  79     if (present (c5)) stop 25
  80   end
  81 end module
  82
  83 program p
  84   use bindcchar
  85   implicit none
  86   character(l) :: a, b(n)
  87   character(:), allocatable :: d, e(:)
  88   a = 'a234567890'
  89   b = 'bcdefghijk'
  90   call not_bindc_optional (a, b)
  91   call bindc_optional (a, b)
  92   call not_bindc_optional2 (a, b)
  93   call bindc_optional2 (a, b)
  94   allocate (d, source=a)
  95   allocate (e, source=b)
  96   call not_bindc_optional (d, e)
  97   call bindc_optional (d, e)
  98   call not_bindc_optional2 (d, e)
  99   call bindc_optional2 (d, e)
 100   call not_bindc_optional_deferred (d, e)
 101   deallocate (d, e)
 102   call non_bindc_optional_missing ()
 103   call bindc_optional_missing ()
 104 end