gcc/testsuite/gfortran.dg/char_result_4.f90

   1 ! Like char_result_3.f90, but the array arguments are pointers.
   2 ! { dg-do run }
   3 pure elemental function double (x)
   4   integer, intent (in) :: x
   5   integer :: double
   6   double = x * 2
   7 end function double
   8
   9 program main
  10   implicit none
  11
  12   interface
  13     pure elemental function double (x)
  14       integer, intent (in) :: x
  15       integer :: double
  16     end function double
  17   end interface
  18
  19   integer, dimension (100:104), target :: a
  20   integer, dimension (:), pointer :: ap
  21   integer :: i, lower
  22
  23   a = (/ (i + 5, i = 0, 4) /)
  24   ap => a
  25   lower = lbound(a,dim=1)
  26
  27   call test (f1 (ap), 35)
  28   call test (f2 (ap), 115)
  29   call test (f3 (ap), 60)
  30   call test (f4 (ap, 104, 2), 21)
  31 contains
  32   function f1 (array)
  33     integer, dimension (:), pointer :: array
  34     character (len = sum (array)) :: f1
  35     f1 = ''
  36   end function f1
  37
  38   function f2 (array)
  39     integer, dimension (:), pointer :: array
  40     character (len = array (101) + a (104) + 100) :: f2
  41     f2 = ''
  42   end function f2
  43
  44   function f3 (array)
  45     integer, dimension (:), pointer :: array
  46     character (len = sum (double (array (101:)))) :: f3
  47     f3 = ''
  48   end function f3
  49
  50   function f4 (array, upper, stride)
  51     integer, dimension (:), pointer :: array
  52     integer :: upper, stride
  53     character (len = sum (array (lower:upper:stride))) :: f4
  54     f4 = ''
  55   end function f4
  56
  57   subroutine test (string, length)
  58     character (len = *) :: string
  59     integer, intent (in) :: length
  60     if (len (string) .ne. length) STOP 1
  61   end subroutine test
  62 end program main