test/Evaluate/rewrite01.f90

! Test expression rewrites, in case where the expression cannot be
! folded to constant values.
! RUN: %flang_fc1 -fdebug-unparse %s 2>&1 | FileCheck %s

! Test rewrites of inquiry intrinsics with arguments whose shape depends
! on a function reference with non constant shape. The function reference
! must be retained.
module some_mod
contains
function returns_array(n, m)
  integer :: returns_array(10:n+10,10:m+10)
  returns_array = 0
end function

function returns_array_2(n)
  integer, intent(in) :: n
  integer :: returns_array_2(n)
  returns_array_2 = 0
end function

function returns_array_3()
  integer :: returns_array_3(7:46+2)
  returns_array_3 = 0
end function

subroutine ubound_test(x, n, m)
  integer :: x(n, m)
  integer :: y(0:n, 0:m) ! UBOUND could be 0 if n or m are < 0
  !CHECK: PRINT *, [INTEGER(4)::int(size(x,dim=1,kind=8),kind=4),int(size(x,dim=2,kind=8),kind=4)]
  print *, ubound(x)
  !CHECK: PRINT *, ubound(returns_array(n,m))
  print *, ubound(returns_array(n, m))
  !CHECK: PRINT *, ubound(returns_array(n,m),dim=1_4)
  print *, ubound(returns_array(n, m), dim=1)
  !CHECK: PRINT *, ubound(returns_array_2(m))
  print *, ubound(returns_array_2(m))
  !CHECK: PRINT *, 42_8
  print *, ubound(returns_array_3(), dim=1, kind=8)
  !CHECK: PRINT *, ubound(y)
  print *, ubound(y)
  !CHECK: PRINT *, ubound(y,1_4)
  print *, ubound(y, 1)
end subroutine

subroutine size_test(x, n, m)
  integer :: x(n, m)
  !CHECK: PRINT *, int(size(x,dim=1,kind=8)*size(x,dim=2,kind=8),kind=4)
  print *, size(x)
  !CHECK: PRINT *, size(returns_array(n,m))
  print *, size(returns_array(n, m))
  !CHECK: PRINT *, size(returns_array(n,m),dim=1_4)
  print *, size(returns_array(n, m), dim=1)
  !CHECK: PRINT *, size(returns_array_2(m))
  print *, size(returns_array_2(m))
  !CHECK: PRINT *, 42_8
  print *, size(returns_array_3(), kind=8)
end subroutine

subroutine shape_test(x, n, m)
  abstract interface
    function foo(n)
      integer, intent(in) :: n
      real, pointer :: foo(:,:)
    end function
  end interface
  procedure(foo), pointer :: pf
  integer :: x(n, m)
  !CHECK: PRINT *, [INTEGER(4)::int(size(x,dim=1,kind=8),kind=4),int(size(x,dim=2,kind=8),kind=4)]
  print *, shape(x)
  !CHECK: PRINT *, shape(returns_array(n,m))
  print *, shape(returns_array(n, m))
  !CHECK: PRINT *, shape(returns_array_2(m))
  print *, shape(returns_array_2(m))
  !CHECK: PRINT *, [INTEGER(8)::42_8]
  print *, shape(returns_array_3(), kind=8)
  !CHECK: PRINT *, 2_4
  print *, rank(pf(1))
end subroutine

subroutine lbound_test(x, n, m)
  integer :: x(n, m)
  integer :: y(0:n, 0:m) ! LBOUND could be 1 if n or m are < 0
  type t
    real, pointer :: p(:, :)
  end type
  type(t) :: a(10)
  !CHECK: PRINT *, [INTEGER(4)::1_4,1_4]
  print *, lbound(x)
  !CHECK: PRINT *, [INTEGER(4)::1_4,1_4]
  print *, lbound(returns_array(n, m))
  !CHECK: PRINT *, 1_4
  print *, lbound(returns_array(n, m), dim=1)
  !CHECK: PRINT *, 1_4
  print *, lbound(returns_array_2(m), dim=1)
  !CHECK: PRINT *, 1_4
  print *, lbound(returns_array_3(), dim=1)
  !CHECK: PRINT *, lbound(y)
  print *, lbound(y)
  !CHECK: PRINT *, lbound(y,1_4)
  print *, lbound(y, 1)
  !CHECK: PRINT *, lbound(a(1_8)%p,dim=1,kind=8)
  print *, lbound(a(1)%p, 1, kind=8)
end subroutine

!CHECK: len_test
subroutine len_test(a,b, c, d, e, n, m)
  character(*), intent(in) :: a
  character(*) :: b
  external b
  character(10), intent(in) :: c
  character(10) :: d
  external d
  integer, intent(in) :: n, m
  character(n), intent(in) :: e
  character(5), parameter :: cparam = "abc  "
  interface
     function fun1(L)
       character(L) :: fun1
       integer :: L
     end function fun1
  end interface
  interface
     function mofun(L)
       character(L) :: mofun
       integer, intent(in) :: L
     end function mofun
  end interface

  !CHECK: PRINT *, int(int(a%len,kind=8),kind=4)
  print *, len(a)
  !CHECK: PRINT *, 5_4
  print *, len(a(1:5))
  !CHECK: PRINT *, len(b(a))
  print *, len(b(a))
  !CHECK: PRINT *, len(b(a)//a)
  print *, len(b(a) // a)
  !CHECK: PRINT *, 10_4
  print *, len(c)
  !CHECK: PRINT *, len(c(int(i,kind=8):int(j,kind=8)))
  print *, len(c(i:j))
  !CHECK: PRINT *, 5_4
  print *, len(c(1:5))
  !CHECK: PRINT *, 10_4
  print *, len(d(c))
  !CHECK: PRINT *, 20_4
  print *, len(d(c) // c)
  !CHECK: PRINT *, 0_4
  print *, len(a(10:4))
  !CHECK: PRINT *, int(max(0_8,int(m,kind=8)-int(n,kind=8)+1_8),kind=4)
  print *, len(a(n:m))
  !CHECK: PRINT *, len(b(a(int(n,kind=8):int(m,kind=8))))
  print *, len(b(a(n:m)))
  !CHECK: PRINT *, int(max(0_8,max(0_8,int(n,kind=8))-4_8+1_8),kind=4)
  print *, len(e(4:))
  !CHECK: PRINT *, len(fun1(n-m))
  print *, len(fun1(n-m))
  !CHECK: PRINT *, len(mofun(m+1_4))
  print *, len(mofun(m+1))
  !CHECK: PRINT *, 3_4
  print *, len(trim(cparam))
  !CHECK: PRINT *, len(trim(c))
  print *, len(trim(c))
  !CHECK: PRINT *, 40_4
  print *, len(repeat(c, 4))
  !CHECK: PRINT *, len(repeat(c,int(i,kind=8)))
  print *, len(repeat(c, i))
end subroutine len_test

!CHECK-LABEL: associate_tests
subroutine associate_tests(p)
  real, pointer :: p(:)
  real :: a(10:20)
  interface
    subroutine may_change_p_bounds(p)
      real, pointer :: p(:)
    end subroutine
  end interface
  associate(x => p)
    call may_change_p_bounds(p)
    !CHECK: PRINT *, lbound(x,dim=1,kind=8), size(x,dim=1,kind=8)+lbound(x,dim=1,kind=8)-1_8, size(x,dim=1,kind=8)
    print *, lbound(x, 1, kind=8), ubound(x, 1, kind=8), size(x, 1, kind=8)
  end associate
  associate(x => p+1)
    call may_change_p_bounds(p)
    !CHECK: PRINT *, 1_8, size(x,dim=1,kind=8), size(x,dim=1,kind=8)
    print *, lbound(x, 1, kind=8), ubound(x, 1, kind=8), size(x, 1, kind=8)
  end associate
  associate(x => a)
    !CHECK: PRINT *, 10_8, 20_8, 11_8
    print *, lbound(x, 1, kind=8), ubound(x, 1, kind=8), size(x, 1, kind=8)
  end associate
  associate(x => a+42.)
    !CHECK: PRINT *, 1_8, 11_8, 11_8
    print *, lbound(x, 1, kind=8), ubound(x, 1, kind=8), size(x, 1, kind=8)
  end associate
end subroutine

!CHECK-LABEL: array_constructor
subroutine array_constructor(a, u, v, w, x, y, z)
  real :: a(4)
  integer :: u(:), v(1), w(2), x(4), y(4), z(2, 2)
  interface
    function return_allocatable()
     real, allocatable :: return_allocatable(:)
    end function
  end interface
  !CHECK: PRINT *, size([REAL(4)::return_allocatable(),return_allocatable()])
  print *, size([return_allocatable(), return_allocatable()])
  !CHECK: PRINT *, [INTEGER(4)::x+y]
  print *, (/x/) + (/y/)
  !CHECK: PRINT *, [INTEGER(4)::x]+[INTEGER(4)::z]
  print *, (/x/) + (/z/)
  !CHECK: PRINT *, [INTEGER(4)::x+y,x+y]
  print *, (/x, x/) + (/y, y/)
  !CHECK: PRINT *, [INTEGER(4)::x,x]+[INTEGER(4)::x,z]
  print *, (/x, x/) + (/x, z/)
  !CHECK: PRINT *, [INTEGER(4)::x,w,w]+[INTEGER(4)::w,w,x]
  print *, (/x, w, w/) + (/w, w, x/)
  !CHECK: PRINT *, [INTEGER(4)::x]+[INTEGER(4)::1_4,2_4,3_4,4_4]
  print *, (/x/) + (/1, 2, 3, 4/)
  !CHECK: PRINT *, [INTEGER(4)::v]+[INTEGER(4)::1_4]
  print *, (/v/) + (/1/)
  !CHECK: PRINT *, [INTEGER(4)::x]+[INTEGER(4)::u]
  print *, (/x/) + (/u/)
  !CHECK: PRINT *, [INTEGER(4)::u]+[INTEGER(4)::u]
  print *, (/u/) + (/u/)
  !CHECK: PRINT *, [REAL(4)::a**x]
  print *, (/a/) ** (/x/)
  !CHECK: PRINT *, [REAL(4)::a]**[INTEGER(4)::z]
  print *, (/a/) ** (/z/)
end subroutine

!CHECK-LABEL: array_ctor_implied_do_index
subroutine array_ctor_implied_do_index(x, j)
  integer :: x(:)
  integer(8) :: j
  character(10) :: c
  !CHECK: PRINT *, size([INTEGER(4)::(x(1_8:i:1_8),INTEGER(8)::i=1_8,2_8,1_8)])
  print *, size([(x(1:i), integer(8)::i=1,2)])
  !CHECK: PRINT *, int(0_8+2_8*(0_8+max((j-1_8+1_8)/1_8,0_8)),kind=4)
  print *, size([(x(1:j), integer(8)::i=1,2)])
  !CHECK: PRINT *, len([(c(i:i),INTEGER(8)::i=1_8,4_8,1_8)])
  print *, len([(c(i:i), integer(8)::i = 1,4)])
end subroutine

end module