gcc/testsuite/gfortran.dg/actual_array_result_1.f90

   1 ! { dg-do run }
   2 ! PR fortan/31692
   3 ! Passing array valued results to procedures
   4 !
   5 ! Test case contributed by rakuen_himawari@yahoo.co.jp
   6 module one
   7   integer :: flag = 0
   8 contains
   9   function foo1 (n)
  10     integer :: n
  11     integer :: foo1(n)
  12     if (flag == 0) then
  13       call bar1 (n, foo1)
  14     else
  15       call bar2 (n, foo1)
  16     end if
  17   end function
  18
  19   function foo2 (n)
  20     implicit none
  21     integer :: n
  22     integer,ALLOCATABLE :: foo2(:)
  23     allocate (foo2(n))
  24     if (flag == 0) then
  25       call bar1 (n, foo2)
  26     else
  27       call bar2 (n, foo2)
  28     end if
  29   end function
  30
  31   function foo3 (n)
  32     implicit none
  33     integer :: n
  34     integer,ALLOCATABLE :: foo3(:)
  35     allocate (foo3(n))
  36     foo3 = 0
  37     call bar2(n, foo3(2:(n-1)))  ! Check that sections are OK
  38   end function
  39
  40   subroutine bar1 (n, array)     ! Checks assumed size formal arg.
  41     integer :: n
  42     integer :: array(*)
  43     integer :: i
  44     do i = 1, n
  45       array(i) = i
  46     enddo
  47   end subroutine
  48
  49   subroutine bar2(n, array)     ! Checks assumed shape formal arg.
  50     integer :: n
  51     integer :: array(:)
  52     integer :: i
  53     do i = 1, size (array, 1)
  54       array(i) = i
  55     enddo
  56    end subroutine
  57 end module
  58
  59 program main
  60   use one
  61   integer :: n
  62   n = 3
  63   if(any (foo1(n) /= [ 1,2,3 ])) call abort()
  64   if(any (foo2(n) /= [ 1,2,3 ])) call abort()
  65   flag = 1
  66   if(any (foo1(n) /= [ 1,2,3 ])) call abort()
  67   if(any (foo2(n) /= [ 1,2,3 ])) call abort()
  68   n = 5
  69   if(any (foo3(n) /= [ 0,1,2,3,0 ])) call abort()
  70 end program
  71 ! { dg-final { cleanup-modules "one" } }