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   character (len = 50), pointer :: textp2
  46
  47   a = 42
  48   textp => textt
  49   textp2 => textt(1:50)
  50
  51   call test (f1 (textp), 70)
  52   call test (f2 (textp, textp), 95)
  53   call test (f3 (textp), 105)
  54   call test (f4 (textp), 192)
  55   call test (f5 (textp), 140)
  56   call test (f6 (textp), 29)
  57
  58   call indirect (textp2)
  59 contains
  60   function f3 (string)
  61     integer, parameter :: l1 = 30
  62     character (len = *), pointer :: string
  63     character (len = len (string) + l1 + 5) :: f3
  64     f3 = ''
  65   end function f3
  66
  67   function f4 (string)
  68     character (len = len (text) - 10), pointer :: string
  69     character (len = len (string) + len (text) + a) :: f4
  70     f4 = ''
  71   end function f4
  72
  73   function f5 (string)
  74     character (len = *), pointer :: string
  75     character (len = len (double (string))) :: f5
  76     f5 = ''
  77   end function f5
  78
  79   function f6 (string)
  80     character (len = *), pointer :: string
  81     character (len = len (string (a:))) :: f6
  82     f6 = ''
  83   end function f6
  84
  85   subroutine indirect (textp2)
  86     character (len = 50), pointer :: textp2
  87
  88     call test (f1 (textp), 70)
  89     call test (f2 (textp, textp), 95)
  90     call test (f3 (textp), 105)
  91     call test (f4 (textp), 192)
  92     call test (f5 (textp), 140)
  93     call test (f6 (textp), 29)
  94
  95     call test (f1 (textp2), 50)
  96     call test (f2 (textp2, textp), 65)
  97     call test (f3 (textp2), 85)
  98     call test (f5 (textp2), 100)
  99     call test (f6 (textp2), 9)
 100   end subroutine indirect
 101
 102   subroutine test (string, length)
 103     character (len = *) :: string
 104     integer, intent (in) :: length
 105     if (len (string) .ne. length) call abort
 106   end subroutine test
 107 end program main