gcc/testsuite/gfortran.dg/submodule_10.f08

   1 ! { dg-do compile }
   2 ! { dg-require-visibility "" }
   3 !
   4 ! Checks that PRIVATE enities are visible to submodules.
   5 !
   6 ! Contributed by Salvatore Filippone  <salvatore.filippone@uniroma2.it>
   7 !
   8 module const_mod
   9   integer, parameter  :: ndig=8
  10   integer, parameter  :: ipk_ = selected_int_kind(ndig)
  11   integer, parameter  :: longndig=12
  12   integer, parameter  :: long_int_k_ = selected_int_kind(longndig)
  13   integer, parameter  :: mpik_ = kind(1)
  14
  15   integer(ipk_), parameter, public :: success_=0
  16
  17 end module const_mod
  18
  19
  20 module error_mod
  21   use const_mod
  22
  23   integer(ipk_), parameter, public :: act_ret_=0
  24   integer(ipk_), parameter, public :: act_print_=1
  25   integer(ipk_), parameter, public :: act_abort_=2
  26
  27   integer(ipk_), parameter, public ::  no_err_ = 0
  28
  29   public error, errcomm, get_numerr, &
  30        & error_handler, &
  31        & ser_error_handler, par_error_handler
  32
  33
  34   interface error_handler
  35     module subroutine ser_error_handler(err_act)
  36       integer(ipk_), intent(inout) ::  err_act
  37     end subroutine ser_error_handler
  38     module subroutine par_error_handler(ictxt,err_act)
  39       integer(mpik_), intent(in) ::  ictxt
  40       integer(ipk_), intent(in) ::  err_act
  41     end subroutine par_error_handler
  42   end interface
  43
  44   interface error
  45     module subroutine serror()
  46     end subroutine serror
  47     module subroutine perror(ictxt,abrt)
  48       integer(mpik_), intent(in) ::  ictxt
  49       logical, intent(in), optional  :: abrt
  50     end subroutine perror
  51   end interface
  52
  53
  54   interface error_print_stack
  55     module subroutine par_error_print_stack(ictxt)
  56       integer(mpik_), intent(in) ::  ictxt
  57     end subroutine par_error_print_stack
  58     module subroutine ser_error_print_stack()
  59     end subroutine ser_error_print_stack
  60   end interface
  61
  62   interface errcomm
  63     module subroutine errcomm(ictxt, err)
  64       integer(mpik_), intent(in)   :: ictxt
  65       integer(ipk_), intent(inout):: err
  66     end subroutine errcomm
  67   end interface errcomm
  68
  69
  70   private
  71
  72   type errstack_node
  73
  74     integer(ipk_) ::   err_code=0
  75     character(len=20)        ::   routine=''
  76     integer(ipk_),dimension(5)     ::   i_err_data=0
  77     character(len=40)        ::   a_err_data=''
  78     type(errstack_node), pointer :: next
  79
  80   end type errstack_node
  81
  82
  83   type errstack
  84     type(errstack_node), pointer :: top => null()
  85     integer(ipk_) :: n_elems=0
  86   end type errstack
  87
  88
  89   type(errstack), save  :: error_stack
  90   integer(ipk_), save   :: error_status    = no_err_
  91   integer(ipk_), save   :: verbosity_level = 1
  92   integer(ipk_), save   :: err_action      = act_abort_
  93   integer(ipk_), save   :: debug_level     = 0, debug_unit, serial_debug_level=0
  94
  95 contains
  96 end module error_mod
  97
  98 submodule (error_mod) error_impl_mod
  99   use const_mod
 100 contains
 101   ! checks whether an error has occurred on one of the processes in the execution pool
 102   subroutine errcomm(ictxt, err)
 103     integer(mpik_), intent(in)   :: ictxt
 104     integer(ipk_), intent(inout):: err
 105
 106
 107   end subroutine errcomm
 108
 109   subroutine ser_error_handler(err_act)
 110     implicit none
 111     integer(ipk_), intent(inout) ::  err_act
 112
 113     if (err_act /= act_ret_)     &
 114          &  call error()
 115     if (err_act == act_abort_) stop
 116
 117     return
 118   end subroutine ser_error_handler
 119
 120   subroutine par_error_handler(ictxt,err_act)
 121     implicit none
 122     integer(mpik_), intent(in) ::  ictxt
 123     integer(ipk_), intent(in) ::  err_act
 124
 125     if (err_act == act_print_)     &
 126          &  call error(ictxt, abrt=.false.)
 127     if (err_act == act_abort_)      &
 128          &  call error(ictxt, abrt=.true.)
 129
 130     return
 131
 132   end subroutine par_error_handler
 133
 134   subroutine par_error_print_stack(ictxt)
 135     integer(mpik_), intent(in) ::  ictxt
 136
 137     call error(ictxt, abrt=.false.)
 138
 139   end subroutine par_error_print_stack
 140
 141   subroutine ser_error_print_stack()
 142
 143     call error()
 144   end subroutine ser_error_print_stack
 145
 146   subroutine serror()
 147
 148     implicit none
 149
 150   end subroutine serror
 151
 152   subroutine perror(ictxt,abrt)
 153     use const_mod
 154     implicit none
 155     integer(mpik_), intent(in) :: ictxt
 156     logical, intent(in), optional  :: abrt
 157
 158   end subroutine perror
 159
 160 end submodule error_impl_mod
 161
 162 program testlk
 163   use error_mod
 164   implicit none
 165
 166   call error()
 167
 168   stop
 169 end program testlk