gcc/testsuite/gfortran.dg/char_result_6.f90

   1 ! Like char_result_5.f90, but the function arguments are pointers to scalars.
   2 ! { dg-do run }
   3 pure function select (selector, iftrue, iffalse)
   4   logical, intent (in) :: selector
   5   integer, intent (in) :: iftrue, iffalse
   6   integer :: select
   7
   8   if (selector) then
   9     select = iftrue
  10   else
  11     select = iffalse
  12   end if
  13 end function select
  14
  15 program main
  16   implicit none
  17
  18   interface
  19     pure function select (selector, iftrue, iffalse)
  20       logical, intent (in) :: selector
  21       integer, intent (in) :: iftrue, iffalse
  22       integer :: select
  23     end function select
  24   end interface
  25
  26   type pair
  27     integer :: left, right
  28   end type pair
  29
  30   integer, target :: i
  31   integer, pointer :: ip
  32   real, target :: r
  33   real, pointer :: rp
  34   logical, target :: l
  35   logical, pointer :: lp
  36   complex, target :: c
  37   complex, pointer :: cp
  38   character, target :: ch
  39   character, pointer :: chp
  40   type (pair), target :: p
  41   type (pair), pointer :: pp
  42
  43   i = 100
  44   r = 50.5
  45   l = .true.
  46   c = (10.9, 11.2)
  47   ch = '1'
  48   p%left = 40
  49   p%right = 50
  50
  51   ip => i
  52   rp => r
  53   lp => l
  54   cp => c
  55   chp => ch
  56   pp => p
  57
  58   call test (f1 (ip), 200)
  59   call test (f2 (rp), 100)
  60   call test (f3 (lp), 50)
  61   call test (f4 (cp), 10)
  62   call test (f5 (chp), 11)
  63   call test (f6 (pp), 145)
  64 contains
  65   function f1 (i)
  66     integer, pointer :: i
  67     character (len = abs (i) * 2) :: f1
  68     f1 = ''
  69   end function f1
  70
  71   function f2 (r)
  72     real, pointer :: r
  73     character (len = floor (r) * 2) :: f2
  74     f2 = ''
  75   end function f2
  76
  77   function f3 (l)
  78     logical, pointer :: l
  79     character (len = select (l, 50, 55)) :: f3
  80     f3 = ''
  81   end function f3
  82
  83   function f4 (c)
  84     complex, pointer :: c
  85     character (len = int (c)) :: f4
  86     f4 = ''
  87   end function f4
  88
  89   function f5 (c)
  90     character, pointer :: c
  91     character (len = scan ('123456789', c) + 10) :: f5
  92     f5 = ''
  93   end function f5
  94
  95   function f6 (p)
  96     type (pair), pointer :: p
  97     integer :: i
  98     character (len = sum ((/ p%left, p%right, (i, i = 1, 10) /))) :: f6
  99     f6 = ''
 100   end function f6
 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