actual_procedure_1.f90

来自「用于进行gcc测试」· F90 代码 · 共 72 行

! { dg-do run }
! Tests the fix for PR36433 in which a check for the array size
! or character length of the actual arguments of foo and bar
! would reject this legal code.
!
! Contributed by Paul Thomas <[e-mail]>
!
module m
contains
  function proc4 (arg, chr)
    integer, dimension(10) :: proc4
    integer, intent(in) :: arg
    character(8), intent(inout) :: chr
    proc4 = arg
    chr = "proc4"
  end function
  function chr_proc ()
    character(8) :: chr_proc
    chr_proc = "chr_proc"
  end function
end module

program procPtrTest
  use m
  character(8) :: chr
  interface
    function proc_ext (arg, chr)
      integer, dimension(10) :: proc_ext
      integer, intent(in) :: arg
      character(8), intent(inout) :: chr
    end function
  end interface
! Check the passing of a module function
  call foo (proc4, chr)
  if (trim (chr) .ne. "proc4") call abort
! Check the passing of an external function
  call foo (proc_ext, chr)
! Check the passing of a character function
  if (trim (chr) .ne. "proc_ext") call abort
  call bar (chr_proc)
contains
  subroutine foo (p, chr)
    character(8), intent(inout) :: chr
    integer :: i(10)
    interface
      function p (arg, chr)
        integer, dimension(10) :: p
        integer, intent(in) :: arg
        character(8), intent(inout) :: chr
      end function
    end interface
    i = p (99, chr)
    if (any(i .ne. 99)) call abort
  end subroutine
  subroutine bar (p)
    interface
      function p ()
        character(8):: p
      end function
    end interface
    if (p () .ne. "chr_proc") call abort
  end subroutine
end program 

function proc_ext (arg, chr)
  integer, dimension(10) :: proc_ext
  integer, intent(in) :: arg
  character(8), intent(inout) :: chr
  proc_ext = arg
  chr = "proc_ext"
end function
! { dg-final { cleanup-modules "m" } }