gcc/testsuite/gfortran.dg/elemental_optional_args_5.f03

   1 ! { dg-do run }
   2 !
   3 ! PR fortran/50981
   4 ! Test the handling of optional, polymorphic and non-polymorphic arguments
   5 ! to elemental procedures.
   6 !
   7 ! Original testcase by Tobias Burnus <burnus@net-b.de>
   8
   9 implicit none
  10 type t
  11   integer :: a
  12 end type t
  13
  14 type t2
  15   integer, allocatable :: a
  16   integer, allocatable :: a2(:)
  17   integer, pointer :: p => null()
  18   integer, pointer :: p2(:) => null()
  19 end type t2
  20
  21 type(t), allocatable :: ta, taa(:)
  22 type(t), pointer :: tp, tpa(:)
  23 class(t), allocatable :: ca, caa(:)
  24 class(t), pointer :: cp, cpa(:)
  25
  26 type(t2) :: x
  27
  28 integer :: s, v(2)
  29
  30 tp => null()
  31 tpa => null()
  32 cp => null()
  33 cpa => null()
  34
  35 ! =============== sub1 ==================
  36 ! SCALAR COMPONENTS: Non alloc/assoc
  37
  38 s = 3
  39 v = [9, 33]
  40
  41 call sub1 (s, x%a, .false.)
  42 call sub1 (v, x%a, .false.)
  43 !print *, s, v
  44 if (s /= 3) call abort()
  45 if (any (v /= [9, 33])) call abort()
  46
  47 call sub1 (s, x%p, .false.)
  48 call sub1 (v, x%p, .false.)
  49 !print *, s, v
  50 if (s /= 3) call abort()
  51 if (any (v /= [9, 33])) call abort()
  52
  53
  54 ! SCALAR COMPONENTS: alloc/assoc
  55
  56 allocate (x%a, x%p)
  57 x%a = 4
  58 x%p = 5
  59 call sub1 (s, x%a, .true.)
  60 call sub1 (v, x%a, .true.)
  61 !print *, s, v
  62 if (s /= 4*2) call abort()
  63 if (any (v /= [4*2, 4*2])) call abort()
  64
  65 call sub1 (s, x%p, .true.)
  66 call sub1 (v, x%p, .true.)
  67 !print *, s, v
  68 if (s /= 5*2) call abort()
  69 if (any (v /= [5*2, 5*2])) call abort()
  70
  71
  72 ! ARRAY COMPONENTS: Non alloc/assoc
  73
  74 v = [9, 33]
  75
  76 call sub1 (v, x%a2, .false.)
  77 !print *, v
  78 if (any (v /= [9, 33])) call abort()
  79
  80 call sub1 (v, x%p2, .false.)
  81 !print *, v
  82 if (any (v /= [9, 33])) call abort()
  83
  84
  85 ! ARRAY COMPONENTS: alloc/assoc
  86
  87 allocate (x%a2(2), x%p2(2))
  88 x%a2(:) = [84, 82]
  89 x%p2    = [35, 58]
  90
  91 call sub1 (v, x%a2, .true.)
  92 !print *, v
  93 if (any (v /= [84*2, 82*2])) call abort()
  94
  95 call sub1 (v, x%p2, .true.)
  96 !print *, v
  97 if (any (v /= [35*2, 58*2])) call abort()
  98
  99
 100 ! =============== sub_t ==================
 101 ! SCALAR DT: Non alloc/assoc
 102
 103 s = 3
 104 v = [9, 33]
 105
 106 call sub_t (s, ta, .false.)
 107 call sub_t (v, ta, .false.)
 108 !print *, s, v
 109 if (s /= 3) call abort()
 110 if (any (v /= [9, 33])) call abort()
 111
 112 call sub_t (s, tp, .false.)
 113 call sub_t (v, tp, .false.)
 114 !print *, s, v
 115 if (s /= 3) call abort()
 116 if (any (v /= [9, 33])) call abort()
 117
 118 call sub_t (s, ca, .false.)
 119 call sub_t (v, ca, .false.)
 120 !print *, s, v
 121 if (s /= 3) call abort()
 122 if (any (v /= [9, 33])) call abort()
 123
 124 call sub_t (s, cp, .false.)
 125 call sub_t (v, cp, .false.)
 126 !print *, s, v
 127 if (s /= 3) call abort()
 128 if (any (v /= [9, 33])) call abort()
 129
 130 ! SCALAR COMPONENTS: alloc/assoc
 131
 132 allocate (ta, tp, ca, cp)
 133 ta%a = 4
 134 tp%a = 5
 135 ca%a = 6
 136 cp%a = 7
 137
 138 call sub_t (s, ta, .true.)
 139 call sub_t (v, ta, .true.)
 140 !print *, s, v
 141 if (s /= 4*2) call abort()
 142 if (any (v /= [4*2, 4*2])) call abort()
 143
 144 call sub_t (s, tp, .true.)
 145 call sub_t (v, tp, .true.)
 146 !print *, s, v
 147 if (s /= 5*2) call abort()
 148 if (any (v /= [5*2, 5*2])) call abort()
 149
 150 call sub_t (s, ca, .true.)
 151 call sub_t (v, ca, .true.)
 152 !print *, s, v
 153 if (s /= 6*2) call abort()
 154 if (any (v /= [6*2, 6*2])) call abort()
 155
 156 call sub_t (s, cp, .true.)
 157 call sub_t (v, cp, .true.)
 158 !print *, s, v
 159 if (s /= 7*2) call abort()
 160 if (any (v /= [7*2, 7*2])) call abort()
 161
 162 ! ARRAY COMPONENTS: Non alloc/assoc
 163
 164 v = [9, 33]
 165
 166 call sub_t (v, taa, .false.)
 167 !print *, v
 168 if (any (v /= [9, 33])) call abort()
 169
 170 call sub_t (v, tpa, .false.)
 171 !print *, v
 172 if (any (v /= [9, 33])) call abort()
 173
 174 call sub_t (v, caa, .false.)
 175 !print *, v
 176 if (any (v /= [9, 33])) call abort()
 177
 178 call sub_t (v, cpa, .false.)
 179 !print *, v
 180 if (any (v /= [9, 33])) call abort()
 181
 182 deallocate(ta, tp, ca, cp)
 183
 184
 185 ! ARRAY COMPONENTS: alloc/assoc
 186
 187 allocate (taa(2), tpa(2))
 188 taa(1:2)%a = [44, 444]
 189 tpa(1:2)%a = [55, 555]
 190 allocate (caa(2), source=[t(66), t(666)])
 191 allocate (cpa(2), source=[t(77), t(777)])
 192
 193 select type (caa)
 194 type is (t)
 195   if (any (caa(:)%a /= [66, 666])) call abort()
 196 end select
 197
 198 select type (cpa)
 199 type is (t)
 200   if (any (cpa(:)%a /= [77, 777])) call abort()
 201 end select
 202
 203 call sub_t (v, taa, .true.)
 204 !print *, v
 205 if (any (v /= [44*2, 444*2])) call abort()
 206
 207 call sub_t (v, tpa, .true.)
 208 !print *, v
 209 if (any (v /= [55*2, 555*2])) call abort()
 210
 211
 212 call sub_t (v, caa, .true.)
 213 !print *, v
 214 if (any (v /= [66*2, 666*2])) call abort()
 215
 216 call sub_t (v, cpa, .true.)
 217 !print *, v
 218 if (any (v /= [77*2, 777*2])) call abort()
 219
 220 deallocate (taa, tpa, caa, cpa)
 221
 222
 223 contains
 224
 225   elemental subroutine sub1 (x, y, alloc)
 226     integer, intent(inout) :: x
 227     integer, intent(in), optional :: y
 228     logical, intent(in) :: alloc
 229     if (alloc .neqv. present (y)) &
 230       x = -99
 231     if (present(y)) &
 232       x = y*2
 233   end subroutine sub1
 234
 235   elemental subroutine sub_t(x, y, alloc)
 236     integer, intent(inout) :: x
 237     type(t), intent(in), optional :: y
 238     logical, intent(in) :: alloc
 239     if (alloc .neqv. present (y)) &
 240       x = -99
 241     if (present(y)) &
 242       x = y%a*2
 243   end subroutine sub_t
 244
 245 end
 246