gcc/testsuite/gfortran.dg/host_assoc_call_4.f90

   1 ! { dg-do compile }
   2 !
   3 ! PR fortran/37445, in which the first version of the fix regressed on the
   4 ! calls to GetBasicElementData; picking up the local GetBasicElementData instead.
   5 !
   6 ! Contributed by Norman S Clerman < clerman@fuse.net>
   7 ! and reduced by Tobias Burnus <burnus@gcc.gnu.org>
   8 !
   9 MODULE ErrElmnt
  10   IMPLICIT NONE
  11   TYPE :: TErrorElement
  12     integer :: i
  13   end type TErrorElement
  14 contains
  15   subroutine GetBasicData ( AnElement, ProcedureName, ErrorNumber,    &
  16                             Level, Message, ReturnStat)
  17     type (TErrorElement) :: AnElement
  18     character (*, 1), optional ::       &
  19       ProcedureName
  20     integer (4), optional :: ErrorNumber
  21     character (*, 1), optional :: Level
  22     character (*, 1), optional :: Message
  23     integer (4), optional :: ReturnStat
  24   end subroutine GetBasicData
  25 end module ErrElmnt
  26
  27 MODULE ErrorMod
  28   USE ErrElmnt, only: GetBasicElementData => GetBasicData , TErrorElement
  29   IMPLICIT NONE
  30 contains
  31   subroutine GetBasicData ()
  32     integer (4) :: CallingStat, LocalErrorNum
  33     character (20, 1) :: LocalErrorMessage
  34     character (20, 1) :: LocalProcName
  35     character (20, 1) :: Locallevel
  36     type (TErrorElement) :: AnElement
  37     call GetBasicElementData (AnElement, LocalProcName, LocalErrorNum, LocalLevel, LocalErrorMessage, CallingStat)
  38   end subroutine GetBasicData
  39   SUBROUTINE WH_ERR ()
  40     integer (4) :: ErrorNumber, CallingStat
  41     character (20, 1) :: ProcedureName
  42     character (20, 1) :: ErrorLevel
  43     character (20, 1) :: ErrorMessage
  44     type (TErrorElement) :: TargetElement
  45     call GetBasicElementData (TargetElement, ProcedureName, ErrorNumber, ErrorLevel, ErrorMessage, CallingStat)
  46   end subroutine WH_ERR
  47 end module ErrorMod
  48 ! { dg-final { cleanup-modules "ErrElmnt ErrorMod" } }