gcc/testsuite/gfortran.dg/actual_procedure_1.f90

   1 ! { dg-do run }
   2 ! Tests the fix for PR36433 in which a check for the array size
   3 ! or character length of the actual arguments of foo and bar
   4 ! would reject this legal code.
   5 !
   6 ! Contributed by Paul Thomas <pault@gcc.gnu.org>
   7 !
   8 module m
   9 contains
  10   function proc4 (arg, chr)
  11     integer, dimension(10) :: proc4
  12     integer, intent(in) :: arg
  13     character(8), intent(inout) :: chr
  14     proc4 = arg
  15     chr = "proc4"
  16   end function
  17   function chr_proc ()
  18     character(8) :: chr_proc
  19     chr_proc = "chr_proc"
  20   end function
  21 end module
  22
  23 program procPtrTest
  24   use m
  25   character(8) :: chr
  26   interface
  27     function proc_ext (arg, chr)
  28       integer, dimension(10) :: proc_ext
  29       integer, intent(in) :: arg
  30       character(8), intent(inout) :: chr
  31     end function
  32   end interface
  33 ! Check the passing of a module function
  34   call foo (proc4, chr)
  35   if (trim (chr) .ne. "proc4") call abort
  36 ! Check the passing of an external function
  37   call foo (proc_ext, chr)
  38 ! Check the passing of a character function
  39   if (trim (chr) .ne. "proc_ext") call abort
  40   call bar (chr_proc)
  41 contains
  42   subroutine foo (p, chr)
  43     character(8), intent(inout) :: chr
  44     integer :: i(10)
  45     interface
  46       function p (arg, chr)
  47         integer, dimension(10) :: p
  48         integer, intent(in) :: arg
  49         character(8), intent(inout) :: chr
  50       end function
  51     end interface
  52     i = p (99, chr)
  53     if (any(i .ne. 99)) call abort
  54   end subroutine
  55   subroutine bar (p)
  56     interface
  57       function p ()
  58         character(8):: p
  59       end function
  60     end interface
  61     if (p () .ne. "chr_proc") call abort
  62   end subroutine
  63 end program
  64
  65 function proc_ext (arg, chr)
  66   integer, dimension(10) :: proc_ext
  67   integer, intent(in) :: arg
  68   character(8), intent(inout) :: chr
  69   proc_ext = arg
  70   chr = "proc_ext"
  71 end function
  72 ! { dg-final { cleanup-modules "m" } }