gcc/testsuite/gfortran.dg/default_initialization_3.f90

   1 ! { dg-do run }
   2 ! Test the fix for PR34438, in which default initializers
   3 ! forced the derived type to be static; ie. initialized once
   4 ! during the lifetime of the programme.  Instead, they should
   5 ! be initialized each time they come into scope.
   6 !
   7 ! Contributed by Sven Buijssen <sven.buijssen@math.uni-dortmund.de>
   8 ! Third test is from  Dominique Dhumieres <dominiq@lps.ens.fr>
   9 !
  10 module demo
  11    type myint
  12      integer :: bar = 42
  13    end type myint
  14 end module demo
  15
  16 ! As the name implies, this was the original testcase
  17 ! provided by the contributor....
  18 subroutine original
  19   use demo
  20   integer val1 (6)
  21   integer val2 (6)
  22   call recfunc (1)
  23   if (any (val1 .ne. (/1, 2, 3, 1, 2, 3/))) call abort ()
  24   if (any (val2 .ne. (/1, 2, 3, 4, 4, 4/))) call abort ()
  25 contains
  26
  27   recursive subroutine recfunc (ivalue)
  28     integer, intent(in) :: ivalue
  29     type(myint) :: foo1
  30     type(myint) :: foo2 = myint (99)
  31     foo1%bar = ivalue
  32     foo2%bar = ivalue
  33     if (ivalue .le. 3) then
  34       val1(ivalue) = foo1%bar
  35       val2(ivalue) = foo2%bar
  36       call recfunc (ivalue + 1)
  37       val1(ivalue + 3) = foo1%bar
  38       val2(ivalue + 3) = foo2%bar
  39     endif
  40   end subroutine recfunc
  41 end subroutine original
  42
  43 ! ...who came up with this one too.
  44 subroutine func (ivalue, retval1, retval2)
  45   use demo
  46   integer, intent(in) :: ivalue
  47   type(myint) :: foo1
  48   type(myint) :: foo2 = myint (77)
  49   type(myint) :: retval1
  50   type(myint) :: retval2
  51   retval1 = foo1
  52   retval2 = foo2
  53   foo1%bar = 999
  54   foo2%bar = 999
  55 end subroutine func
  56
  57 subroutine other
  58   use demo
  59   interface
  60     subroutine func(ivalue, rv1, rv2)
  61       use demo
  62       integer, intent(in) :: ivalue
  63       type(myint) :: foo, rv1, rv2
  64    end subroutine func
  65   end interface
  66   type(myint) :: val1, val2
  67   call func (1, val1, val2)
  68   if ((val1%bar .ne. 42) .or. (val2%bar .ne. 77)) call abort ()
  69   call func (2, val1, val2)
  70   if ((val1%bar .ne. 42) .or. (val2%bar .ne. 999)) call abort ()
  71
  72 end subroutine other
  73
  74 MODULE M1
  75   TYPE T1
  76     INTEGER :: i=7
  77   END TYPE T1
  78 CONTAINS
  79   FUNCTION F1(d1) RESULT(res)
  80     INTEGER :: res
  81     TYPE(T1), INTENT(OUT) :: d1
  82     TYPE(T1), INTENT(INOUT) :: d2
  83     res=d1%i
  84     d1%i=0
  85     RETURN
  86   ENTRY   E1(d2) RESULT(res)
  87     res=d2%i
  88     d2%i=0
  89   END FUNCTION F1
  90 END MODULE M1
  91
  92 ! This tests the fix of a regression caused by the first version
  93 ! of the patch.
  94 subroutine dominique ()
  95   USE M1
  96   TYPE(T1) :: D1
  97   D1=T1(3)
  98   if (F1(D1) .ne. 7) call abort ()
  99   D1=T1(3)
 100   if (E1(D1) .ne. 3) call abort ()
 101 END
 102
 103 ! Run both tests.
 104   call original
 105   call other
 106   call dominique
 107 end