gcc/testsuite/gfortran.dg/pr112407a.f90

   1 ! { dg-do run }
   2 ! Test of an issue found in the investigation of PR112407
   3 ! Contributed by Tomas Trnka  <trnka@scm.com>
   4 !
   5 module m
   6   private new_t
   7
   8   type s
   9     procedure(),pointer,nopass :: op
  10   end type
  11
  12   type :: t
  13     integer :: i
  14     type (s) :: s
  15   contains
  16     procedure :: new_t
  17     procedure :: bar
  18     procedure :: add_t
  19     generic :: new => new_t, bar
  20     generic, public :: assignment(=) => add_t
  21     final :: final_t
  22   end type
  23
  24   integer :: i = 0, finals = 0
  25
  26 contains
  27   recursive subroutine new_t (arg1, arg2)
  28     class(t), intent(out) :: arg1
  29     type(t), intent(in)  :: arg2
  30     i = i + 1
  31
  32     print "(a,2i4)", "new_t", arg1%i, arg2%i
  33     if (i .ge. 10) return
  34
  35 ! According to F2018(8.5.10), arg1 should be undefined on invocation, unless
  36 ! any sub-components are default initialised. gfc used to set arg1%i = 0.
  37     if (arg1%i .ne. arg2%i) then
  38       arg1%i = arg2%i
  39       call arg1%new(arg2)
  40     endif
  41   end
  42
  43   subroutine bar(arg)
  44     class(t), intent(out) :: arg
  45     call arg%new(t(42, s(new_t)))
  46   end
  47
  48   subroutine add_t (arg1, arg2)
  49     class(t), intent(out) :: arg1
  50     type(t), intent(in)  :: arg2
  51     call arg1%new (arg2)
  52   end
  53
  54   impure elemental subroutine final_t (arg1)
  55     type(t), intent(in) :: arg1
  56     finals = finals + 1
  57   end
  58 end
  59
  60   use m
  61   class(t), allocatable :: x
  62   allocate(x)
  63   x%i = 0
  64   call x%new()                   ! gfortran used to output 10*'new_t'
  65   print "(3i4)", x%i, i, finals  !           -||-          0 10 11
  66 !
  67 ! The other brands output 2*'new_t' + 42 2 3 and now so does gfc :-)
  68   if (x%i .ne. 42) stop 1
  69   if (i .ne. 2) stop 2
  70   if (finals .ne. 3) stop 3
  71 end