gcc/testsuite/gfortran.dg/use_only_1.f90

   1 ! { dg-do run }
   2 ! { dg-options "-O1" }
   3 ! Checks the fix for PR33541, in which a requirement of
   4 ! F95 11.3.2 was not being met: The local names 'x' and
   5 ! 'y' coming from the USE statements without an ONLY clause
   6 ! should not survive in the presence of the locally renamed
   7 ! versions. In fixing the PR, the same correction has been
   8 ! made to generic interfaces.
   9 !
  10 ! Reported by Reported by John Harper in
  11 ! http://gcc.gnu.org/ml/fortran/2007-09/msg00397.html
  12 !
  13 MODULE xmod
  14   integer(4) :: x = -666
  15   private foo, bar
  16   interface xfoobar
  17     module procedure foo, bar
  18   end interface
  19 contains
  20   integer function foo ()
  21     foo = 42
  22   end function
  23   integer function bar (a)
  24     integer a
  25     bar = a
  26   end function
  27 END MODULE xmod
  28
  29 MODULE ymod
  30   integer(4) :: y = -666
  31   private foo, bar
  32   interface yfoobar
  33     module procedure foo, bar
  34   end interface
  35 contains
  36   integer function foo ()
  37     foo = 42
  38   end function
  39   integer function bar (a)
  40     integer a
  41     bar = a
  42   end function
  43 END MODULE ymod
  44
  45   integer function xfoobar () ! These function as defaults should...
  46     xfoobar = 99
  47   end function
  48
  49   integer function yfoobar () ! ...the rename works correctly.
  50     yfoobar = 99
  51   end function
  52
  53 PROGRAM test2uses
  54   implicit integer(2) (a-z)
  55   x = 666  ! These assignments generate implicitly typed
  56   y = 666  ! local variables 'x' and 'y'.
  57   call test1
  58   call test2
  59   call test3
  60 contains
  61   subroutine test1  ! Test the fix of the original PR
  62     USE xmod
  63     USE xmod, ONLY: xrenamed => x
  64     USE ymod, ONLY: yrenamed => y
  65     USE ymod
  66     implicit integer(2) (a-z)
  67     if (kind(xrenamed) == kind(x)) call abort ()
  68     if (kind(yrenamed) == kind(y)) call abort ()
  69   end subroutine
  70
  71   subroutine test2  ! Test the fix applies to generic interfaces
  72     USE xmod
  73     USE xmod, ONLY: xfoobar_renamed => xfoobar
  74     USE ymod, ONLY: yfoobar_renamed => yfoobar
  75     USE ymod
  76     implicit integer(4) (a-z)
  77     if (xfoobar_renamed (42) == xfoobar ()) call abort ()
  78     if (yfoobar_renamed (42) == yfoobar ()) call abort ()
  79   end subroutine
  80
  81   subroutine test3  ! Check that USE_NAME == LOCAL_NAME is OK
  82     USE xmod
  83     USE xmod, ONLY: x => x, xfoobar => xfoobar
  84     USE ymod, ONLY: y => y, yfoobar => yfoobar
  85     USE ymod
  86     if (kind (x) /= 4) call abort ()
  87     if (kind (y) /= 4) call abort ()
  88     if (xfoobar (77) /= 77_4) call abort ()
  89     if (yfoobar (77) /= 77_4) call abort ()
  90   end subroutine
  91 END PROGRAM test2uses