gcc/testsuite/gfortran.dg/missing_optional_dummy_7.f90

   1 ! { dg-do run }
   2 ! PR fortran/112772 - test absent OPTIONAL, ALLOCATABLE/POINTER class dummies
   3
   4 program main
   5   implicit none
   6   type t
   7   end type t
   8   call test_c_a ()
   9   call test_u_a ()
  10   call test_c_p ()
  11   call test_u_p ()
  12 contains
  13   ! class, allocatable
  14   subroutine test_c_a (msg1)
  15     class(t), optional, allocatable :: msg1(:)
  16     if (present (msg1)) stop 1
  17     call assert_c_a ()
  18     call assert_c_a (msg1)
  19   end
  20
  21   subroutine assert_c_a (msg2)
  22     class(t), optional, allocatable :: msg2(:)
  23     if (present (msg2)) stop 2
  24   end
  25
  26   ! unlimited polymorphic, allocatable
  27   subroutine test_u_a (msg1)
  28     class(*), optional, allocatable :: msg1(:)
  29     if (present (msg1)) stop 3
  30     call assert_u_a ()
  31     call assert_u_a (msg1)
  32   end
  33
  34   subroutine assert_u_a (msg2)
  35     class(*), optional, allocatable :: msg2(:)
  36     if (present (msg2)) stop 4
  37   end
  38
  39   ! class, pointer
  40   subroutine test_c_p (msg1)
  41     class(t), optional, pointer :: msg1(:)
  42     if (present (msg1)) stop 5
  43     call assert_c_p ()
  44     call assert_c_p (msg1)
  45   end
  46
  47   subroutine assert_c_p (msg2)
  48     class(t), optional, pointer :: msg2(:)
  49     if (present (msg2)) stop 6
  50   end
  51
  52   ! unlimited polymorphic, pointer
  53   subroutine test_u_p (msg1)
  54     class(*), optional, pointer :: msg1(:)
  55     if (present (msg1)) stop 7
  56     call assert_u_p ()
  57     call assert_u_p (msg1)
  58   end
  59
  60   subroutine assert_u_p (msg2)
  61     class(*), optional, pointer :: msg2(:)
  62     if (present (msg2)) stop 8
  63   end
  64 end