gcc/testsuite/gfortran.dg/allocatable_function_8.f90

   1 ! { dg-do run }
   2 ! { dg-require-visibility "" }
   3 ! Test the fix for PR61459 and PR58883.
   4 !
   5 ! Contributed by John Wingate  <johnww@tds.net>
   6 !             and Tao Song  <songtao.thu@gmail.com>
   7 !
   8 module a
   9
  10    implicit none
  11    private
  12    public :: f_segfault, f_segfault_plus, f_workaround
  13    integer, dimension(2,2) :: b = reshape([1,-1,1,1],[2,2])
  14
  15 contains
  16
  17    function f_segfault(x)
  18       real, dimension(:), allocatable :: f_segfault
  19       real, dimension(:), intent(in)  :: x
  20       allocate(f_segfault(2))
  21       f_segfault = matmul(b,x)
  22    end function f_segfault
  23
  24 ! Sefaulted without the ALLOCATE as well.
  25    function f_segfault_plus(x)
  26       real, dimension(:), allocatable :: f_segfault_plus
  27       real, dimension(:), intent(in)  :: x
  28       f_segfault_plus = matmul(b,x)
  29    end function f_segfault_plus
  30
  31    function f_workaround(x)
  32       real, dimension(:), allocatable :: f_workaround
  33       real, dimension(:), intent(in)  :: x
  34       real, dimension(:), allocatable :: tmp
  35       allocate(f_workaround(2),tmp(2))
  36       tmp = matmul(b,x)
  37       f_workaround = tmp
  38    end function f_workaround
  39
  40 end module a
  41
  42 program main
  43    use a
  44    implicit none
  45    real, dimension(2) :: x = 1.0, y
  46 ! PR61459
  47    y = f_workaround (x)
  48    if (any (f_segfault (x) .ne. y)) call abort
  49    if (any (f_segfault_plus (x) .ne. y)) call abort
  50 ! PR58883
  51    if (any (foo () .ne. reshape([1,2,3,4,5,6,7,8],[2,4]))) call abort
  52 contains
  53   function foo()
  54     integer, allocatable  :: foo(:,:)
  55     integer, allocatable  :: temp(:)
  56
  57     temp = [1,2,3,4,5,6,7,8]
  58     foo = reshape(temp,[2,4])
  59   end function
  60 end program main