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