summaryrefslogtreecommitdiff
path: root/gcc/testsuite/gfortran.dg/actual_procedure_1.f90
blob: 5327cb73d7f522e4c196d5f77c077abba8b15506 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
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 <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" } }