gcc/testsuite/gfortran.dg/PR94022.f90

   1 ! { dg-do run }
   2 !
   3 ! Test the fix for PR94022
   4 !
   5
   6 function isasa_f(a) result(s)
   7   implicit none
   8
   9   integer, intent(in) :: a(..)
  10
  11   logical :: s
  12
  13   select rank(a)
  14   rank(*)
  15     s = .true.
  16   rank default
  17     s = .false.
  18   end select
  19   return
  20 end function isasa_f
  21
  22 function isasa_c(a) result(s) bind(c)
  23   use, intrinsic :: iso_c_binding, only: c_int, c_bool
  24
  25   implicit none
  26
  27   integer(kind=c_int), intent(in) :: a(..)
  28
  29   logical(kind=c_bool) :: s
  30
  31   select rank(a)
  32   rank(*)
  33     s = .true.
  34   rank default
  35     s = .false.
  36   end select
  37   return
  38 end function isasa_c
  39
  40 program isasa_p
  41
  42   implicit none
  43
  44   interface
  45     function isasa_f(a) result(s)
  46       implicit none
  47       integer, intent(in) :: a(..)
  48       logical             :: s
  49     end function isasa_f
  50     function isasa_c(a) result(s) bind(c)
  51       use, intrinsic :: iso_c_binding, only: c_int, c_bool
  52       implicit none
  53       integer(kind=c_int), intent(in) :: a(..)
  54       logical(kind=c_bool)            :: s
  55     end function isasa_c
  56   end interface
  57
  58   integer, parameter :: sz = 7
  59   integer, parameter :: lb = 3
  60   integer, parameter :: ub = 9
  61   integer, parameter :: ex = ub-lb+1
  62
  63   integer :: arr(sz,lb:ub)
  64
  65   arr = 1
  66   if (asaf_a(arr, lb+1, ub-1)) stop 1
  67   if (asaf_p(arr, lb+1, ub-1)) stop 2
  68   if (asaf_a(arr, 2, ex-1))    stop 3
  69   if (asaf_p(arr, 2, ex-1))    stop 4
  70   if (asac_a(arr, lb+1, ub-1)) stop 5
  71   if (asac_p(arr, lb+1, ub-1)) stop 6
  72   if (asac_a(arr, 2, ex-1))    stop 7
  73   if (asac_p(arr, 2, ex-1))    stop 8
  74
  75   stop
  76
  77 contains
  78
  79   function asaf_a(a, lb, ub) result(s)
  80     integer, intent(in) :: lb
  81     integer, target, intent(in) :: a(sz,lb:*)
  82     integer, intent(in) :: ub
  83
  84     logical :: s
  85
  86     s = isasa_f(a(:,lb:ub))
  87     return
  88   end function asaf_a
  89
  90   function asaf_p(a, lb, ub) result(s)
  91     integer,         intent(in) :: lb
  92     integer, target, intent(in) :: a(sz,lb:*)
  93     integer,         intent(in) :: ub
  94
  95     logical :: s
  96
  97     integer, pointer :: p(:,:)
  98
  99     p => a(:,lb:ub)
 100     s = isasa_f(p)
 101     return
 102   end function asaf_p
 103
 104   function asac_a(a, lb, ub) result(s)
 105     integer, intent(in) :: lb
 106     integer, target, intent(in) :: a(sz,lb:*)
 107     integer, intent(in) :: ub
 108
 109     logical :: s
 110
 111     s = logical(isasa_c(a(:,lb:ub)))
 112     return
 113   end function asac_a
 114
 115   function asac_p(a, lb, ub) result(s)
 116     integer,         intent(in) :: lb
 117     integer, target, intent(in) :: a(sz,lb:*)
 118     integer,         intent(in) :: ub
 119
 120     logical :: s
 121
 122     integer, pointer :: p(:,:)
 123
 124     p => a(:,lb:ub)
 125     s = logical(isasa_c(p))
 126     return
 127   end function asac_p
 128
 129 end program isasa_p
 130
 131
 132