gcc/testsuite/gfortran.dg/finalize_47.f90

   1 ! { dg-do run }
   2 !
   3 ! Check that PR91316 is fixed. Note removal of recursive I/O.
   4 !
   5 ! Contributed by Jose Rui Faustino de Sousa  <jrfsousa@gcc.gnu.org>
   6 !
   7 ! NAGFOR complains correctly about the finalization of an INTENT(OUT) dummy
   8 ! with an impure finalization subroutine, within a pure procedure.
   9 ! It also complains about the finalization of final_set, which does not seem
  10 ! to be correct (see finalize_50.f90).
  11 ! Both procedures have been made impure so that this testcase runs with both
  12 ! compilers.
  13 !
  14 module final_m
  15   implicit none
  16   private
  17   public ::        &
  18     assignment(=)
  19
  20   public :: &
  21     final_t
  22
  23   public ::     &
  24     final_init, &
  25     final_set,  &
  26     final_get,  &
  27     final_end
  28
  29   type :: final_t
  30     private
  31     integer :: n = -1
  32   contains
  33     final :: final_end
  34   end type final_t
  35
  36   interface assignment(=)
  37     module procedure final_init
  38   end interface assignment(=)
  39
  40   integer, public :: final_ctr = 0
  41   integer, public :: final_res = 0
  42
  43 contains
  44
  45   impure elemental subroutine final_init(this, n)
  46     type(final_t), intent(out) :: this
  47     integer,       intent(in)  :: n
  48     this%n = n
  49   end subroutine final_init
  50
  51   impure elemental function final_set(n) result(this)
  52     integer, intent(in) :: n
  53     type(final_t) :: this
  54     this%n = n
  55   end function final_set
  56
  57   elemental function final_get(this) result(n)
  58     type(final_t), intent(in) :: this
  59     integer :: n
  60     n = this%n
  61   end function final_get
  62
  63   subroutine final_end(this)
  64     type(final_t), intent(inout) :: this
  65 !    print *, "DESTROY: ", this%n !< generates illegal, recursive io in 'final_s4'
  66     final_res = this%n
  67     final_ctr = final_ctr + 1
  68     this%n = -1
  69   end subroutine final_end
  70 end module final_m
  71
  72 program final_p
  73   use final_m
  74   implicit none
  75   type(final_t) :: f0
  76 !  call final_init(f0, 0)
  77   call final_s1()
  78   call final_s2()
  79   call final_s3()
  80   call final_s4()
  81   call final_end(f0)
  82 contains
  83   subroutine final_s1()
  84     type(final_t) :: f
  85     call final_init(f, 1)
  86     print *, "f1: ", final_get(f)
  87     if ((final_ctr .ne. 1) .or. (final_res .ne. -1)) stop 1
  88   end subroutine final_s1
  89   subroutine final_s2()
  90     type(final_t) :: f
  91     f = 2
  92     print *, "f2: ", final_get(f)
  93     if ((final_ctr .ne. 3) .or. (final_res .ne. -1)) stop 1
  94   end subroutine final_s2
  95   subroutine final_s3()
  96     type(final_t) :: f
  97     f = final_set(3)
  98     print *, "f3: ", final_get(f)
  99     if ((final_ctr .ne. 6) .or. (final_res .ne. 3)) stop 1
 100   end subroutine final_s3
 101   subroutine final_s4()
 102     print *, "f4: ", final_get(final_set(4))
 103     if ((final_ctr .ne. 8) .or. (final_res .ne. 4)) stop 1
 104   end subroutine final_s4
 105 end program final_p