gcc/testsuite/gfortran.dg/mapping_1.f90

   1 ! { dg-do run }
   2 ! Tests the fix for PR31213, which exposed rather a lot of
   3 ! bugs - see the PR and the ChangeLog.
   4 !
   5 ! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
   6 !
   7 module mykinds
   8   implicit none
   9   integer, parameter :: ik1 = selected_int_kind (2)
  10   integer, parameter :: ik2 = selected_int_kind (4)
  11   integer, parameter :: dp = selected_real_kind (15,300)
  12 end module mykinds
  13
  14 module spec_xpr
  15   use mykinds
  16   implicit none
  17   integer(ik2) c_size
  18 contains
  19   pure function tricky (str,ugly)
  20     character(*), intent(in) :: str
  21     integer(ik1) :: ia_ik1(len(str))
  22     interface yoagly
  23       pure function ugly(n)
  24         use mykinds
  25         implicit none
  26         integer, intent(in) :: n
  27         complex(dp) :: ugly(3*n+2)
  28       end function ugly
  29     end interface yoagly
  30     logical :: la(size (yoagly (size (ia_ik1))))
  31     integer :: i
  32     character(tricky_helper ((/(.TRUE., i=1, size (la))/)) + c_size) :: tricky
  33
  34     tricky = transfer (yoagly (1), tricky)
  35   end function tricky
  36
  37   pure function tricky_helper (lb)
  38     logical, intent(in) :: lb(:)
  39     integer :: tricky_helper
  40     tricky_helper = 2 * size (lb) + 3
  41   end function tricky_helper
  42 end module spec_xpr
  43
  44 module xtra_fun
  45   implicit none
  46 contains
  47   pure function butt_ugly(n)
  48     use mykinds
  49     implicit none
  50     integer, intent(in) :: n
  51     complex(dp) :: butt_ugly(3*n+2)
  52     real(dp) pi, sq2
  53
  54     pi = 4 * atan (1.0_dp)
  55     sq2 = sqrt (2.0_dp)
  56     butt_ugly = cmplx (pi, sq2, dp)
  57   end function butt_ugly
  58 end module xtra_fun
  59
  60 program spec_test
  61   use mykinds
  62   use spec_xpr
  63   use xtra_fun
  64   implicit none
  65   character(54) :: chr
  66
  67   c_size = 5
  68   if (tricky ('Help me', butt_ugly) .ne. transfer (butt_ugly (1), chr)) call abort ()
  69 end program spec_test