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
  18 ! These two calls replace the previously made call to subroutine
  19 ! set_arrays which was erroneous because of parameter-induced
  20 ! aliasing.
  21   call set_array_listpr (listpr)
  22   call set_array_lisbit (lisbit)
  23
  24   if (any (listpr.ne.lischk)) call abort ()
  25   call sub1
  26   call sub2
  27   call sub3
  28 end
  29 subroutine sub1
  30   common /abc/ mwkx(80)
  31   common /cde/ lischk(20)
  32   dimension    listpr(20),lisbit(10),lispat(8)
  33 !     This workaround was OK
  34   equivalence (listpr(10),lisbit(1)), &
  35               (listpr(10),mwkx(10)),  &
  36               (listpr(10),lispat(1))
  37   call set_array_listpr (listpr)
  38   call set_array_lisbit (lisbit)
  39   if (any (listpr .ne. lischk)) call abort ()
  40 end
  41 !
  42 ! Equivalences not in COMMON
  43 !___________________________
  44 ! This gave incorrect results for the same reason as in MAIN.
  45 subroutine sub2
  46   dimension   mwkx(80)
  47   common /cde/ lischk(20)
  48   dimension    listpr(20),lisbit(10),lispat(8)
  49   equivalence (lispat(1),listpr(10)), &
  50               (mwkx(10),lisbit(1),listpr(10))
  51   call set_array_listpr (listpr)
  52   call set_array_lisbit (lisbit)
  53   if (any (listpr .ne. lischk)) call abort ()
  54 end
  55 ! This gave correct results because the order in which the
  56 ! equivalences are taken is different and was given in the PR.
  57 subroutine sub3
  58   dimension   mwkx(80)
  59   common /cde/ lischk(20)
  60   dimension    listpr(20),lisbit(10),lispat(8)
  61   equivalence (listpr(10),lisbit(1),mwkx(10)), &
  62               (lispat(1),listpr(10))
  63   call set_array_listpr (listpr)
  64   call set_array_lisbit (lisbit)
  65   if (any (listpr .ne. lischk)) call abort ()
  66 end
  67
  68 subroutine set_array_listpr (listpr)
  69   dimension listpr(20)
  70   listpr = 0
  71 end
  72
  73 subroutine set_array_lisbit (lisbit)
  74   dimension lisbit(10)
  75   lisbit = (/(i, i = 1, 10)/)
  76   lisbit((/3,4/)) = 0
  77 end