gcc/testsuite/gfortran.dg/pr99602.f90

   1 ! { dg-do compile }
   2 ! { dg-options "-fcheck=pointer -fdump-tree-original" }
   3 !
   4 ! Test fix of PR99602, where a spurious runtime error was introduced
   5 ! by PR99112. This is the testcase in comment #6 of the PR.
   6 ! PR99602a.f90 turns on the runtime errors by eliminating the pointer
   7 ! attribute from the formal arguments in the abstract interface and
   8 ! prepare_whizard_m2.
   9 !
  10 ! Contributed by Jeurgen Reuter  <juergen.reuter@desy.de>
  11 !
  12 module m
  13   implicit none
  14   private
  15   public :: m_t
  16   type :: m_t
  17      private
  18   end type m_t
  19 end module m
  20
  21 module m2_testbed
  22   use m
  23   implicit none
  24   private
  25   public :: prepare_m2
  26   procedure (prepare_m2_proc), pointer :: prepare_m2 => null ()
  27
  28   abstract interface
  29      subroutine prepare_m2_proc (m2)
  30        import
  31        class(m_t), intent(inout), pointer :: m2
  32      end subroutine prepare_m2_proc
  33   end interface
  34
  35 end module m2_testbed
  36
  37 module a
  38   use m
  39   use m2_testbed, only: prepare_m2
  40   implicit none
  41   private
  42   public :: a_1
  43
  44 contains
  45
  46   subroutine a_1 ()
  47     class(m_t), pointer :: mm
  48     mm => null ()
  49     call prepare_m2 (mm) ! Runtime error triggered here
  50   end subroutine a_1
  51
  52 end module a
  53
  54
  55 module m2
  56   use m
  57   implicit none
  58   private
  59   public :: m2_t
  60
  61   type, extends (m_t) :: m2_t
  62      private
  63    contains
  64      procedure :: read => m2_read
  65   end type m2_t
  66 contains
  67
  68   subroutine m2_read (mm)
  69     class(m2_t), intent(out), target :: mm
  70   end subroutine m2_read
  71 end module m2
  72
  73 program main
  74   use m2_testbed
  75   use a, only: a_1
  76   implicit none
  77   prepare_m2 => prepare_whizard_m2
  78   call a_1 ()
  79
  80 contains
  81
  82   subroutine prepare_whizard_m2 (mm)
  83     use m
  84     use m2
  85     class(m_t), intent(inout), pointer :: mm
  86     if (.not. associated (mm))  allocate (m2_t :: mm)
  87     select type (mm)
  88     type is (m2_t)
  89 !       call mm%read ()  ! Since mm is passed to non-pointer, this generates the error code.
  90     end select
  91   end subroutine prepare_whizard_m2
  92 end program main
  93 ! { dg-final { scan-tree-dump-times "_gfortran_runtime_error_at" 0 "original" } }
  94 ! { dg-final { scan-tree-dump-times "Pointer actual argument" 0 "original" } }