gcc/testsuite/gfortran.dg/is_contiguous_2.f90

   1 ! { dg-do  run }
   2 !
   3 ! PR fortran/45424
   4 ! PR fortran/48820
   5 !
   6 ! Additional run-time checks for IS_CONTIGUOUS with assumed type/rank
   7 program is_contiguous_2
   8   implicit none
   9   real, allocatable :: b(:,:)
  10   real, pointer     :: c(:,:)
  11   integer, volatile :: k
  12   target :: b
  13   allocate(b(10,10))
  14   k = 2
  15   if (fail_ar (b,          .true.) ) stop 1
  16   if (fail_ar (b(::1,::1), .true.) ) stop 2
  17   if (fail_ar (b(::2,::1), .false.)) stop 3
  18   if (fail_ar (b(::1,::2), .false.)) stop 4
  19   if (fail_ar (b(:10,:10), .true. )) stop 5
  20   if (fail_ar (b(: 9,:10), .false.)) stop 6
  21   if (fail_ar (b(2: ,:  ), .false.)) stop 7
  22   if (fail_ar (b(:  ,2: ), .true. )) stop 8
  23   if (fail_ar (b(k: ,:  ), .false.)) stop 9
  24   if (fail_ar (b(:  ,k: ), .true. )) stop 10
  25   if (fail_at (b(::1,k: ), .true. )) stop 11
  26   if (fail_at (b(::k,k: ), .false.)) stop 12
  27   if (fail_at (b(10,k)   , .true. )) stop 13
  28   c => b(::1,:)
  29   if (fail_ar (c,          .true.) ) stop 14
  30   c => b(::2,:)
  31   if (fail_ar (c,          .false.)) stop 15
  32   associate (d => b(:,2:), e => b(::k,:))
  33     if (fail_ar (d,        .true.) ) stop 16
  34     if (fail_ar (e,        .false.)) stop 17
  35   end associate
  36 contains
  37   pure logical function fail_ar (x, expect) result (fail)
  38     real,    dimension(..), intent(in) :: x  ! Assumed rank
  39     logical,                intent(in) :: expect
  40     fail = is_contiguous (x) .neqv. expect
  41   end function fail_ar
  42   pure logical function fail_at (x, expect) result (fail)
  43     type(*), dimension(..), intent(in) :: x  ! Assumed type/assumed rank
  44     logical,                intent(in) :: expect
  45     fail = is_contiguous (x) .neqv. expect
  46   end function fail_at
  47 end program