gcc/testsuite/gfortran.dg/char_result_5.f90

   1 ! Related to PR 15326.  Test calls to string functions whose lengths
   2 ! depend on various types of scalar value.
   3 ! { dg-do run }
   4 pure function select (selector, iftrue, iffalse)
   5   logical, intent (in) :: selector
   6   integer, intent (in) :: iftrue, iffalse
   7   integer :: select
   8
   9   if (selector) then
  10     select = iftrue
  11   else
  12     select = iffalse
  13   end if
  14 end function select
  15
  16 program main
  17   implicit none
  18
  19   interface
  20     pure function select (selector, iftrue, iffalse)
  21       logical, intent (in) :: selector
  22       integer, intent (in) :: iftrue, iffalse
  23       integer :: select
  24     end function select
  25   end interface
  26
  27   type pair
  28     integer :: left, right
  29   end type pair
  30
  31   integer, target :: i
  32   integer, pointer :: ip
  33   real, target :: r
  34   real, pointer :: rp
  35   logical, target :: l
  36   logical, pointer :: lp
  37   complex, target :: c
  38   complex, pointer :: cp
  39   character, target :: ch
  40   character, pointer :: chp
  41   type (pair), target :: p
  42   type (pair), pointer :: pp
  43
  44   character (len = 10) :: dig
  45
  46   i = 100
  47   r = 50.5
  48   l = .true.
  49   c = (10.9, 11.2)
  50   ch = '1'
  51   p%left = 40
  52   p%right = 50
  53
  54   ip => i
  55   rp => r
  56   lp => l
  57   cp => c
  58   chp => ch
  59   pp => p
  60
  61   dig = '1234567890'
  62
  63   call test (f1 (i), 200)
  64   call test (f1 (ip), 200)
  65   call test (f1 (-30), 60)
  66   call test (f1 (i / (-4)), 50)
  67
  68   call test (f2 (r), 100)
  69   call test (f2 (rp), 100)
  70   call test (f2 (70.1), 140)
  71   call test (f2 (r / 4), 24)
  72   call test (f2 (real (i)), 200)
  73
  74   call test (f3 (l), 50)
  75   call test (f3 (lp), 50)
  76   call test (f3 (.false.), 55)
  77   call test (f3 (i < 30), 55)
  78
  79   call test (f4 (c), 10)
  80   call test (f4 (cp), 10)
  81   call test (f4 (cmplx (60.0, r)), 60)
  82   call test (f4 (cmplx (r, 1.0)), 50)
  83
  84   call test (f5 (ch), 11)
  85   call test (f5 (chp), 11)
  86   call test (f5 ('23'), 12)
  87   call test (f5 (dig (3:)), 13)
  88   call test (f5 (dig (10:)), 10)
  89
  90   call test (f6 (p), 145)
  91   call test (f6 (pp), 145)
  92   call test (f6 (pair (20, 10)), 85)
  93   call test (f6 (pair (i / 2, 1)), 106)
  94 contains
  95   function f1 (i)
  96     integer :: i
  97     character (len = abs (i) * 2) :: f1
  98     f1 = ''
  99   end function f1
 100
 101   function f2 (r)
 102     real :: r
 103     character (len = floor (r) * 2) :: f2
 104     f2 = ''
 105   end function f2
 106
 107   function f3 (l)
 108     logical :: l
 109     character (len = select (l, 50, 55)) :: f3
 110     f3 = ''
 111   end function f3
 112
 113   function f4 (c)
 114     complex :: c
 115     character (len = int (c)) :: f4
 116     f4 = ''
 117   end function f4
 118
 119   function f5 (c)
 120     character :: c
 121     character (len = scan ('123456789', c) + 10) :: f5
 122     f5 = ''
 123   end function f5
 124
 125   function f6 (p)
 126     type (pair) :: p
 127     integer :: i
 128     character (len = sum ((/ p%left, p%right, (i, i = 1, 10) /))) :: f6
 129     f6 = ''
 130   end function f6
 131
 132   subroutine test (string, length)
 133     character (len = *) :: string
 134     integer, intent (in) :: length
 135     if (len (string) .ne. length) call abort
 136   end subroutine test
 137 end program main