gcc/testsuite/gfortran.dg/equiv_6.f90

   1 ! { dg-do run }
   2 ! This checks the patch for PR25395, in which equivalences within one
   3 ! segment were broken by indirect equivalences, depending on the
   4 ! offset of the variable that bridges the indirect equivalence.
   5 !
   6 ! This is a fortran95 version of the original testcase, which was
   7 ! contributed by Harald Vogt  <harald.vogt@desy.de>
   8 program check_6
   9   common /abc/ mwkx(80)
  10   common /cde/ lischk(20)
  11   dimension    listpr(20),lisbit(10),lispat(8)
  12 ! This was badly compiled in the PR:
  13   equivalence (listpr(10),lisbit(1),mwkx(10)), &
  14               (lispat(1),listpr(10))
  15   lischk = (/0, 0, 0, 0, 0, 0, 0, 0, 0, 1, &
  16              2, 0, 0, 5, 6, 7, 8, 9,10, 0/)
  17   call set_arrays (listpr, lisbit)
  18   if (any (listpr.ne.lischk)) call abort ()
  19   call sub1
  20   call sub2
  21   call sub3
  22 end
  23 subroutine sub1
  24   common /abc/ mwkx(80)
  25   common /cde/ lischk(20)
  26   dimension    listpr(20),lisbit(10),lispat(8)
  27 !     This workaround was OK
  28   equivalence (listpr(10),lisbit(1)), &
  29               (listpr(10),mwkx(10)),  &
  30               (listpr(10),lispat(1))
  31   call set_arrays (listpr, lisbit)
  32   if (any (listpr .ne. lischk)) call abort ()
  33 end
  34 !
  35 ! Equivalences not in COMMON
  36 !___________________________
  37 ! This gave incorrect results for the same reason as in MAIN.
  38 subroutine sub2
  39   dimension   mwkx(80)
  40   common /cde/ lischk(20)
  41   dimension    listpr(20),lisbit(10),lispat(8)
  42   equivalence (lispat(1),listpr(10)), &
  43               (mwkx(10),lisbit(1),listpr(10))
  44   call set_arrays (listpr, lisbit)
  45   if (any (listpr .ne. lischk)) call abort ()
  46 end
  47 ! This gave correct results because the order in which the
  48 ! equivalences are taken is different and was given in the PR.
  49 subroutine sub3
  50   dimension   mwkx(80)
  51   common /cde/ lischk(20)
  52   dimension    listpr(20),lisbit(10),lispat(8)
  53   equivalence (listpr(10),lisbit(1),mwkx(10)), &
  54               (lispat(1),listpr(10))
  55   call set_arrays (listpr, lisbit)
  56   if (any (listpr .ne. lischk)) call abort ()
  57 end
  58 subroutine set_arrays (listpr, lisbit)
  59   dimension listpr(20),lisbit(10)
  60   listpr = 0
  61   lisbit = (/(i, i = 1, 10)/)
  62   lisbit((/3,4/)) = 0
  63 end