gcc/testsuite/gfortran.dg/optional_absent_9.f90

   1 ! { dg-do run }
   2 ! PR fortran/113377
   3 !
   4 ! Test passing of missing optional scalar dummies of intrinsic type
   5
   6 module m_int
   7   implicit none
   8 contains
   9   subroutine test_int ()
  10     integer :: k = 1
  11     call one     (k)
  12     call one_val (k)
  13     call one_all (k)
  14     call one_ptr (k)
  15   end
  16
  17   subroutine one (i, j)
  18     integer, intent(in)           :: i
  19     integer             ,optional :: j
  20     integer, allocatable :: aa
  21     integer, pointer     :: pp => NULL()
  22     if (present (j)) error stop "j is present"
  23     call two     (i, j)
  24     call two_val (i, j)
  25     call two     (i, aa)
  26     call two     (i, pp)
  27     call two_val (i, aa)
  28     call two_val (i, pp)
  29   end
  30
  31   subroutine one_val (i, j)
  32     integer, intent(in)           :: i
  33     integer, value,      optional :: j
  34     if (present (j)) error stop "j is present"
  35     call two     (i, j)
  36     call two_val (i, j)
  37   end
  38
  39   subroutine one_all (i, j)
  40     integer, intent(in)           :: i
  41     integer, allocatable,optional :: j
  42     if (present (j)) error stop "j is present"
  43 !   call two     (i, j)  ! invalid per F2018:15.5.2.12, par. 3, clause 8
  44 !   call two_val (i, j)  ! dto.
  45     call two_all (i, j)
  46   end
  47
  48   subroutine one_ptr (i, j)
  49     integer, intent(in)           :: i
  50     integer, pointer    ,optional :: j
  51     if (present (j)) error stop "j is present"
  52 !   call two     (i, j)  ! invalid per F2018:15.5.2.12, par. 3, clause 7
  53 !   call two_val (i, j)  ! dto.
  54     call two_ptr (i, j)
  55   end
  56
  57   subroutine two (i, j)
  58     integer, intent(in)           :: i
  59     integer, intent(in), optional :: j
  60     if (present (j)) error stop 11
  61   end
  62
  63   subroutine two_val (i, j)
  64     integer, intent(in)           :: i
  65     integer, value,      optional :: j
  66     if (present (j)) error stop 12
  67   end
  68
  69   subroutine two_all (i, j)
  70     integer, intent(in)           :: i
  71     integer, allocatable,optional :: j
  72     if (present (j)) error stop 13
  73   end
  74
  75   subroutine two_ptr (i, j)
  76     integer, intent(in)           :: i
  77     integer, pointer,    optional :: j
  78     if (present (j)) error stop 14
  79   end
  80 end
  81
  82 module m_char
  83   implicit none
  84 contains
  85   subroutine test_char ()
  86     character :: k = "#"
  87     call one     (k)
  88     call one_val (k)
  89     call one_all (k)
  90     call one_ptr (k)
  91   end
  92
  93   subroutine one (i, j)
  94     character, intent(in)           :: i
  95     character             ,optional :: j
  96     character, allocatable :: aa
  97     character, pointer     :: pp => NULL()
  98     if (present (j)) error stop "j is present"
  99     call two     (i, j)
 100     call two_val (i, j)
 101     call two     (i, aa)
 102     call two     (i, pp)
 103   end
 104
 105   subroutine one_val (i, j)
 106     character, intent(in)           :: i
 107     character, value,      optional :: j
 108     if (present (j)) error stop "j is present"
 109     call two     (i, j)
 110     call two_val (i, j)
 111   end
 112
 113   subroutine one_all (i, j)
 114     character, intent(in)           :: i
 115     character, allocatable,optional :: j
 116     if (present (j)) error stop "j is present"
 117 !   call two     (i, j)  ! invalid per F2018:15.5.2.12, par. 3, clause 8
 118 !   call two_val (i, j)  ! dto.
 119     call two_all (i, j)
 120   end
 121
 122   subroutine one_ptr (i, j)
 123     character, intent(in)           :: i
 124     character, pointer    ,optional :: j
 125     if (present (j)) error stop "j is present"
 126 !   call two     (i, j)  ! invalid per F2018:15.5.2.12, par. 3, clause 7
 127 !   call two_val (i, j)  ! dto.
 128     call two_ptr (i, j)
 129   end
 130
 131   subroutine two (i, j)
 132     character, intent(in)           :: i
 133     character, intent(in), optional :: j
 134     if (present (j)) error stop 21
 135   end
 136
 137   subroutine two_val (i, j)
 138     character, intent(in)           :: i
 139     character, value,      optional :: j
 140     if (present (j)) error stop 22
 141   end
 142
 143   subroutine two_all (i, j)
 144     character, intent(in)           :: i
 145     character, allocatable,optional :: j
 146     if (present (j)) error stop 23
 147   end
 148
 149   subroutine two_ptr (i, j)
 150     character, intent(in)           :: i
 151     character, pointer,    optional :: j
 152     if (present (j)) error stop 24
 153   end
 154 end
 155
 156 module m_char4
 157   implicit none
 158 contains
 159   subroutine test_char4 ()
 160     character(kind=4) :: k = 4_"#"
 161     call one     (k)
 162     call one_val (k)
 163     call one_all (k)
 164     call one_ptr (k)
 165   end
 166
 167   subroutine one (i, j)
 168     character(kind=4), intent(in)           :: i
 169     character(kind=4)             ,optional :: j
 170     character(kind=4), allocatable :: aa
 171     character(kind=4), pointer     :: pp => NULL()
 172     if (present (j)) error stop "j is present"
 173     call two     (i, j)
 174     call two_val (i, j)
 175     call two     (i, aa)
 176     call two     (i, pp)
 177   end
 178
 179   subroutine one_val (i, j)
 180     character(kind=4), intent(in)           :: i
 181     character(kind=4), value,      optional :: j
 182     if (present (j)) error stop "j is present"
 183     call two     (i, j)
 184     call two_val (i, j)
 185   end
 186
 187   subroutine one_all (i, j)
 188     character(kind=4), intent(in)           :: i
 189     character(kind=4), allocatable,optional :: j
 190     if (present (j)) error stop "j is present"
 191 !   call two     (i, j)  ! invalid per F2018:15.5.2.12, par. 3, clause 8
 192 !   call two_val (i, j)  ! dto.
 193     call two_all (i, j)
 194   end
 195
 196   subroutine one_ptr (i, j)
 197     character(kind=4), intent(in)           :: i
 198     character(kind=4), pointer    ,optional :: j
 199     if (present (j)) error stop "j is present"
 200 !   call two     (i, j)  ! invalid per F2018:15.5.2.12, par. 3, clause 7
 201 !   call two_val (i, j)  ! dto.
 202     call two_ptr (i, j)
 203   end
 204
 205   subroutine two (i, j)
 206     character(kind=4), intent(in)           :: i
 207     character(kind=4), intent(in), optional :: j
 208     if (present (j)) error stop 31
 209   end
 210
 211   subroutine two_val (i, j)
 212     character(kind=4), intent(in)           :: i
 213     character(kind=4), value,      optional :: j
 214     if (present (j)) error stop 32
 215   end
 216
 217   subroutine two_all (i, j)
 218     character(kind=4), intent(in)           :: i
 219     character(kind=4), allocatable,optional :: j
 220     if (present (j)) error stop 33
 221   end
 222
 223   subroutine two_ptr (i, j)
 224     character(kind=4), intent(in)           :: i
 225     character(kind=4), pointer,    optional :: j
 226     if (present (j)) error stop 34
 227   end
 228 end
 229
 230 module m_complex
 231   implicit none
 232 contains
 233   subroutine test_complex ()
 234     complex :: k = 3.
 235     call one     (k)
 236     call one_val (k)
 237     call one_all (k)
 238     call one_ptr (k)
 239   end
 240
 241   subroutine one (i, j)
 242     complex, intent(in)           :: i
 243     complex             ,optional :: j
 244     complex, allocatable :: aa
 245     complex, pointer     :: pp => NULL()
 246     if (present (j)) error stop "j is present"
 247     call two     (i, j)
 248     call two_val (i, j)
 249     call two     (i, aa)
 250     call two     (i, pp)
 251   end
 252
 253   subroutine one_val (i, j)
 254     complex, intent(in)           :: i
 255     complex, value,      optional :: j
 256     if (present (j)) error stop "j is present"
 257     call two     (i, j)
 258     call two_val (i, j)
 259   end
 260
 261   subroutine one_all (i, j)
 262     complex, intent(in)           :: i
 263     complex, allocatable,optional :: j
 264     if (present (j)) error stop "j is present"
 265 !   call two     (i, j)  ! invalid per F2018:15.5.2.12, par. 3, clause 8
 266 !   call two_val (i, j)  ! dto.
 267     call two_all (i, j)
 268   end
 269
 270   subroutine one_ptr (i, j)
 271     complex, intent(in)           :: i
 272     complex, pointer    ,optional :: j
 273     if (present (j)) error stop "j is present"
 274 !   call two     (i, j)  ! invalid per F2018:15.5.2.12, par. 3, clause 7
 275 !   call two_val (i, j)  ! dto.
 276     call two_ptr (i, j)
 277   end
 278
 279   subroutine two (i, j)
 280     complex, intent(in)           :: i
 281     complex, intent(in), optional :: j
 282     if (present (j)) error stop 41
 283   end
 284
 285   subroutine two_val (i, j)
 286     complex, intent(in)           :: i
 287     complex, value,      optional :: j
 288     if (present (j)) error stop 42
 289   end
 290
 291   subroutine two_all (i, j)
 292     complex, intent(in)           :: i
 293     complex, allocatable,optional :: j
 294     if (present (j)) error stop 43
 295   end
 296
 297   subroutine two_ptr (i, j)
 298     complex, intent(in)           :: i
 299     complex, pointer,    optional :: j
 300     if (present (j)) error stop 44
 301   end
 302 end
 303
 304 module m_mm
 305   ! Test suggested by Mikael Morin
 306   implicit none
 307   type :: t
 308     integer, allocatable :: c
 309     integer, pointer     :: p => NULL()
 310   end type
 311 contains
 312   subroutine test_mm ()
 313     call s1 (t())
 314   end
 315
 316   subroutine s1 (a)
 317     type(t) :: a
 318     call s2 (a% c)
 319     call s2 (a% p)
 320   end
 321
 322   subroutine s2 (a)
 323     integer, value, optional :: a
 324     if (present(a)) stop 1
 325   end
 326 end
 327
 328 program p
 329   use m_int
 330   use m_char
 331   use m_char4
 332   use m_complex
 333   use m_mm
 334   implicit none
 335   call test_int ()
 336   call test_char ()
 337   call test_char4 ()
 338   call test_complex ()
 339   call test_mm ()
 340 end