gcc/testsuite/gfortran.dg/pr99602b.f90

   1 ! { dg-do run }
   2 ! { dg-options "-fcheck=pointer" }
   3 !
   4 ! Test the fix for PR99602 in which the runtime error,
   5 ! "Proc-pointer actual argument 'model' is not associated" was triggered
   6 ! by the NULL result from model%get_par_data_ptr ("tea ")
   7 !
   8 ! Contributed by Juergen Reuter  <juergen.reuter@desy.de>
   9 !
  10 module model_data
  11   type :: model_data_t
  12      type(modelpar_real_t), dimension(:), pointer :: par_real => null ()
  13    contains
  14      procedure :: get_par_data_ptr => model_data_get_par_data_ptr_name
  15      procedure :: set => field_data_set
  16   end type model_data_t
  17
  18   type :: modelpar_real_t
  19      character (4) :: name
  20      real(4) :: value
  21   end type modelpar_real_t
  22
  23   type(modelpar_real_t), target :: names(2) = [modelpar_real_t("foo ", 1.0), &
  24                                                modelpar_real_t("bar ", 2.0)]
  25   integer :: return_value = 0
  26
  27 contains
  28
  29   function model_data_get_par_data_ptr_name (model, name) result (ptr)
  30     class(model_data_t), intent(in) :: model
  31     character (*), intent(in) :: name
  32     class(modelpar_real_t), pointer :: ptr
  33     integer :: i
  34     ptr => null ()
  35     do i = 1, size (model%par_real)
  36        if (model%par_real(i)%name == name) ptr => model%par_real(i)
  37     end do
  38   end function model_data_get_par_data_ptr_name
  39
  40   subroutine field_data_set (this, ptr)
  41     class(model_data_t), intent(inout) :: this
  42     class(modelpar_real_t), intent(in), pointer :: ptr
  43     if (associated (ptr)) then
  44       return_value = int (ptr%value)
  45     else
  46       return_value = -1
  47     end if
  48   end subroutine
  49
  50 end module model_data
  51
  52   use model_data
  53   class(model_data_t), allocatable :: model
  54   class(modelpar_real_t), pointer :: name_ptr
  55
  56   allocate (model_data_t :: model)
  57   model%par_real => names
  58
  59   call model%set (model%get_par_data_ptr ("bar "))
  60   if (return_value .ne. 2) stop 1
  61   call model%set (model%get_par_data_ptr ("tea ")) ! Triggered runtime error
  62   if (return_value .ne. -1) stop 2
  63 end
  64