char_result_2.f90

来自「linux下编程用 编译软件」· F90 代码 · 共 107 行

! Like char_result_1.f90, but the string arguments are pointers.
! { dg-do run }
pure function double (string)
  character (len = *), intent (in) :: string
  character (len = len (string) * 2) :: double
  double = string // string
end function double

function f1 (string)
  character (len = *), pointer :: string
  character (len = len (string)) :: f1
  f1 = ''
end function f1

function f2 (string1, string2)
  character (len = *), pointer :: string1
  character (len = len (string1) - 20), pointer :: string2
  character (len = len (string1) + len (string2) / 2) :: f2
  f2 = ''
end function f2

program main
  implicit none

  interface
    pure function double (string)
      character (len = *), intent (in) :: string
      character (len = len (string) * 2) :: double
    end function double
    function f1 (string)
      character (len = *), pointer :: string
      character (len = len (string)) :: f1
    end function f1
    function f2 (string1, string2)
      character (len = *), pointer :: string1
      character (len = len (string1) - 20), pointer :: string2
      character (len = len (string1) + len (string2) / 2) :: f2
    end function f2
  end interface

  integer :: a
  character (len = 80) :: text
  character (len = 70), target :: textt
  character (len = 70), pointer :: textp

  a = 42
  textp => textt

  call test (f1 (textp), 70)
  call test (f2 (textp, textp), 95)
  call test (f3 (textp), 105)
  call test (f4 (textp), 192)
  call test (f5 (textp), 140)
  call test (f6 (textp), 29)

  call indirect (textp)
contains
  function f3 (string)
    integer, parameter :: l1 = 30
    character (len = *), pointer :: string
    character (len = len (string) + l1 + 5) :: f3
    f3 = ''
  end function f3

  function f4 (string)
    character (len = len (text) - 10), pointer :: string
    character (len = len (string) + len (text) + a) :: f4
    f4 = ''
  end function f4

  function f5 (string)
    character (len = *), pointer :: string
    character (len = len (double (string))) :: f5
    f5 = ''
  end function f5

  function f6 (string)
    character (len = *), pointer :: string
    character (len = len (string (a:))) :: f6
    f6 = ''
  end function f6

  subroutine indirect (textp2)
    character (len = 50), pointer :: textp2

    call test (f1 (textp), 70)
    call test (f2 (textp, textp), 95)
    call test (f3 (textp), 105)
    call test (f4 (textp), 192)
    call test (f5 (textp), 140)
    call test (f6 (textp), 29)

    call test (f1 (textp2), 50)
    call test (f2 (textp2, textp), 65)
    call test (f3 (textp2), 85)
    call test (f4 (textp2), 192)
    call test (f5 (textp2), 100)
    call test (f6 (textp2), 9)
  end subroutine indirect

  subroutine test (string, length)
    character (len = *) :: string
    integer, intent (in) :: length
    if (len (string) .ne. length) call abort
  end subroutine test
end program main