URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc3/] [gcc/] [testsuite/] [gfortran.dg/] [actual_procedure_1.f90] - Rev 302
Go to most recent revision | Compare with Previous | Blame | View Log
! { 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 <pault@gcc.gnu.org>
!
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" } }
Go to most recent revision | Compare with Previous | Blame | View Log