Subversion Repositories openrisc

! { 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 

!

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" } }