gcc/testsuite/gfortran.dg/char_result_2.f90

   1 ! Like char_result_1.f90, but the string arguments are pointers.
   2 ! { dg-do run }
   3 pure function double (string)
   4   character (len = *), intent (in) :: string
   5   character (len = len (string) * 2) :: double
   6   double = string // string
   7 end function double
   8
   9 function f1 (string)
  10   character (len = *), pointer :: string
  11   character (len = len (string)) :: f1
  12   f1 = ''
  13 end function f1
  14
  15 function f2 (string1, string2)
  16   character (len = *), pointer :: string1
  17   character (len = len (string1) - 20), pointer :: string2
  18   character (len = len (string1) + len (string2) / 2) :: f2
  19   f2 = ''
  20 end function f2
  21
  22 program main
  23   implicit none
  24
  25   interface
  26     pure function double (string)
  27       character (len = *), intent (in) :: string
  28       character (len = len (string) * 2) :: double
  29     end function double
  30     function f1 (string)
  31       character (len = *), pointer :: string
  32       character (len = len (string)) :: f1
  33     end function f1
  34     function f2 (string1, string2)
  35       character (len = *), pointer :: string1
  36       character (len = len (string1) - 20), pointer :: string2
  37       character (len = len (string1) + len (string2) / 2) :: f2
  38     end function f2
  39   end interface
  40
  41   integer :: a
  42   character (len = 80) :: text
  43   character (len = 70), target :: textt
  44   character (len = 70), pointer :: textp
  45
  46   a = 42
  47   textp => textt
  48
  49   call test (f1 (textp), 70)
  50   call test (f2 (textp, textp), 95)
  51   call test (f3 (textp), 105)
  52   call test (f4 (textp), 192)
  53   call test (f5 (textp), 140)
  54   call test (f6 (textp), 29)
  55
  56   call indirect (textp)
  57 contains
  58   function f3 (string)
  59     integer, parameter :: l1 = 30
  60     character (len = *), pointer :: string
  61     character (len = len (string) + l1 + 5) :: f3
  62     f3 = ''
  63   end function f3
  64
  65   function f4 (string)
  66     character (len = len (text) - 10), pointer :: string
  67     character (len = len (string) + len (text) + a) :: f4
  68     f4 = ''
  69   end function f4
  70
  71   function f5 (string)
  72     character (len = *), pointer :: string
  73     character (len = len (double (string))) :: f5
  74     f5 = ''
  75   end function f5
  76
  77   function f6 (string)
  78     character (len = *), pointer :: string
  79     character (len = len (string (a:))) :: f6
  80     f6 = ''
  81   end function f6
  82
  83   subroutine indirect (textp2)
  84     character (len = 50), pointer :: textp2
  85
  86     call test (f1 (textp), 70)
  87     call test (f2 (textp, textp), 95)
  88     call test (f3 (textp), 105)
  89     call test (f4 (textp), 192)
  90     call test (f5 (textp), 140)
  91     call test (f6 (textp), 29)
  92
  93     call test (f1 (textp2), 50)
  94     call test (f2 (textp2, textp), 65)
  95     call test (f3 (textp2), 85)
  96     call test (f4 (textp2), 192)
  97     call test (f5 (textp2), 100)
  98     call test (f6 (textp2), 9)
  99   end subroutine indirect
 100
 101   subroutine test (string, length)
 102     character (len = *) :: string
 103     integer, intent (in) :: length
 104     if (len (string) .ne. length) call abort
 105   end subroutine test
 106 end program main