blob: 35958515d385d3e23de09349dbbc35e221992cce [file] [log] [blame]
! { dg-do run }
! { dg-additional-options "-fdump-tree-original" }
! F2018 - examples with array descriptor
module m
use iso_c_binding, only: c_char
implicit none (type, external)
contains
! Assumed-shape array, nonallocatable/nonpointer
subroutine as1 (x1) bind(C)
character(kind=c_char, len=1) :: x1(:)
if (size(x1) /= 6) stop
if (len(x1) /= 1) stop
if (any (x1 /= ['g', &
'd', &
'f', &
's', &
'3', &
'5'])) stop 1
x1 = ['1', &
'h', &
'f', &
'3', &
'4', &
'h']
end
subroutine as2 (x2) bind(C)
character(kind=c_char, len=2) :: x2(:)
if (size(x2) /= 6) stop
if (len(x2) /= 2) stop
if (any (x2 /= ['ab', &
'fd', &
'D4', &
'54', &
'ga', &
'hg'])) stop
x2 = ['ab', &
'hd', &
'fj', &
'a4', &
'4a', &
'hf']
end
subroutine as3 (xn, n) bind(C)
integer :: n
character(kind=c_char, len=n) :: xn(:)
if (size(xn) /= 6) stop
if (len(xn) /= 5) stop
if (any (xn /= ['DDGhf', &
'hdrh$', &
'fDGSl', &
'DFHs3', &
'43grG', &
'hFG$k'])) stop
xn = ['FDGhf', &
'hdrhg', &
'fDgFl', &
'DFHs3', &
'4a54G', &
'hSs6k']
end
subroutine as4 (xstar) bind(C)
character(kind=c_char, len=*) :: xstar(:)
if (size(xstar) /= 6) stop
if (len(xstar) /= 5) stop
if (any (xstar /= ['DDGhf', &
'hdrh$', &
'fDGSl', &
'DFHs3', &
'43grG', &
'hFG$k'])) stop
xstar = ['FDGhf', &
'hdrhg', &
'fDgFl', &
'DFHs3', &
'4a54G', &
'hSs6k']
end
! Assumed-rank array, nonallocatable/nonpointer
subroutine ar1 (x1) bind(C)
character(kind=c_char, len=1) :: x1(..)
if (size(x1) /= 6) stop
if (len(x1) /= 1) stop
select rank(x1)
rank(1)
if (any (x1 /= ['g', &
'd', &
'f', &
's', &
'3', &
'5'])) stop
x1 = ['1', &
'h', &
'f', &
'3', &
'4', &
'h']
rank default
stop
end select
end
subroutine ar2 (x2) bind(C)
character(kind=c_char, len=2) :: x2(..)
if (size(x2) /= 6) stop
if (len(x2) /= 2) stop
select rank(x2)
rank(1)
if (any (x2 /= ['ab', &
'fd', &
'D4', &
'54', &
'ga', &
'hg'])) stop
x2 = ['ab', &
'hd', &
'fj', &
'a4', &
'4a', &
'hf']
rank default
stop
end select
end
subroutine ar3 (xn, n) bind(C)
integer :: n
character(len=n) :: xn(..)
if (size(xn) /= 6) stop
if (len(xn) /= 5) stop
select rank(xn)
rank(1)
if (any (xn /= ['DDGhf', &
'hdrh$', &
'fDGSl', &
'DFHs3', &
'43grG', &
'hFG$k'])) stop
xn = ['FDGhf', &
'hdrhg', &
'fDgFl', &
'DFHs3', &
'4a54G', &
'hSs6k']
rank default
stop
end select
end
subroutine ar4 (xstar) bind(C)
character(kind=c_char, len=*) :: xstar(..)
if (size(xstar) /= 6) stop
if (len(xstar) /= 5) stop
select rank(xstar)
rank(1)
if (any (xstar /= ['DDGhf', &
'hdrh$', &
'fDGSl', &
'DFHs3', &
'43grG', &
'hFG$k'])) stop
xstar = ['FDGhf', &
'hdrhg', &
'fDgFl', &
'DFHs3', &
'4a54G', &
'hSs6k']
rank default
stop
end select
end
! ALLOCATABLE
! Assumed-shape array, allocatable
subroutine a5a (xcolon) bind(C)
character(kind=c_char, len=:), allocatable :: xcolon(:)
if (.not. allocated (xcolon)) stop
if (size(xcolon) /= 6) stop
if (len(xcolon) /= 5) stop
if (any (xcolon /= ['DDGhf', &
'hdrh$', &
'fDGSl', &
'DFHs3', &
'43grG', &
'hFG$k'])) stop
xcolon = ['FDGhf', &
'hdrhg', &
'fDgFl', &
'DFHs3', &
'4a54G', &
'hSs6k']
end
! Assumed-rank array, allocatable
subroutine a5ar (xcolon) bind(C)
character(kind=c_char, len=:), allocatable :: xcolon(..)
if (.not. allocated (xcolon)) stop
if (size(xcolon) /= 6) stop
if (len(xcolon) /= 5) stop
select rank(xcolon)
rank(1)
if (any (xcolon /= ['DDGhf', &
'hdrh$', &
'fDGSl', &
'DFHs3', &
'43grG', &
'hFG$k'])) stop
xcolon = ['FDGhf', &
'hdrhg', &
'fDgFl', &
'DFHs3', &
'4a54G', &
'hSs6k']
rank default
stop
end select
end
! POINTER
! Assumed-shape array, pointer
subroutine a5p (xcolon) bind(C)
character(kind=c_char, len=:), pointer :: xcolon(:)
if (.not. associated (xcolon)) stop
if (size(xcolon) /= 6) stop
if (len(xcolon) /= 5) stop
if (any (xcolon /= ['DDGhf', &
'hdrh$', &
'fDGSl', &
'DFHs3', &
'43grG', &
'hFG$k'])) stop
xcolon = ['FDGhf', &
'hdrhg', &
'fDgFl', &
'DFHs3', &
'4a54G', &
'hSs6k']
end
! Assumed-rank array, pointer
subroutine a5pr (xcolon) bind(C)
character(kind=c_char, len=:), pointer :: xcolon(..)
if (.not. associated (xcolon)) stop
if (size(xcolon) /= 6) stop
if (len(xcolon) /= 5) stop
select rank(xcolon)
rank(1)
if (any (xcolon /= ['DDGhf', &
'hdrh$', &
'fDGSl', &
'DFHs3', &
'43grG', &
'hFG$k'])) stop
xcolon = ['FDGhf', &
'hdrhg', &
'fDgFl', &
'DFHs3', &
'4a54G', &
'hSs6k']
rank default
stop
end select
end
end module m
program main
use m
implicit none (type, external)
character(kind=c_char, len=1) :: str1a6(6)
character(kind=c_char, len=2) :: str2a6(6)
character(kind=c_char, len=5) :: str5a6(6)
character(kind=c_char, len=:), allocatable :: astr5a6(:)
character(kind=c_char, len=:), pointer :: pstr5a6(:)
allocate (character(kind=c_char, len=5) :: astr5a6(6), pstr5a6(6))
! assumed shape - with array descriptor
str1a6 = ['g', &
'd', &
'f', &
's', &
'3', &
'5']
call as1 (str1a6)
if (any (str1a6 /= ['1', &
'h', &
'f', &
'3', &
'4', &
'h'])) stop
str2a6 = ['ab', &
'fd', &
'D4', &
'54', &
'ga', &
'hg']
call as2 (str2a6)
if (any (str2a6 /= ['ab', &
'hd', &
'fj', &
'a4', &
'4a', &
'hf'])) stop
str5a6 = ['DDGhf', &
'hdrh$', &
'fDGSl', &
'DFHs3', &
'43grG', &
'hFG$k']
call as3 (str5a6, 5)
if (any (str5a6 /= ['FDGhf', &
'hdrhg', &
'fDgFl', &
'DFHs3', &
'4a54G', &
'hSs6k'])) stop
str5a6 = ['DDGhf', &
'hdrh$', &
'fDGSl', &
'DFHs3', &
'43grG', &
'hFG$k']
call as4 (str5a6)
if (any (str5a6 /= ['FDGhf', &
'hdrhg', &
'fDgFl', &
'DFHs3', &
'4a54G', &
'hSs6k'])) stop
! assumed rank - with array descriptor
str1a6 = ['g', &
'd', &
'f', &
's', &
'3', &
'5']
call ar1 (str1a6)
if (any (str1a6 /= ['1', &
'h', &
'f', &
'3', &
'4', &
'h'])) stop
str2a6 = ['ab', &
'fd', &
'D4', &
'54', &
'ga', &
'hg']
call ar2 (str2a6)
if (any (str2a6 /= ['ab', &
'hd', &
'fj', &
'a4', &
'4a', &
'hf'])) stop
str5a6 = ['DDGhf', &
'hdrh$', &
'fDGSl', &
'DFHs3', &
'43grG', &
'hFG$k']
call ar3 (str5a6, 5)
if (any (str5a6 /= ['FDGhf', &
'hdrhg', &
'fDgFl', &
'DFHs3', &
'4a54G', &
'hSs6k'])) stop
str5a6 = ['DDGhf', &
'hdrh$', &
'fDGSl', &
'DFHs3', &
'43grG', &
'hFG$k']
call ar4 (str5a6)
if (any (str5a6 /= ['FDGhf', &
'hdrhg', &
'fDgFl', &
'DFHs3', &
'4a54G', &
'hSs6k'])) stop
! allocatable - with array descriptor
astr5a6(:) = ['DDGhf', &
'hdrh$', &
'fDGSl', &
'DFHs3', &
'43grG', &
'hFG$k']
call a5a (astr5a6)
if (any (astr5a6 /= ['FDGhf', &
'hdrhg', &
'fDgFl', &
'DFHs3', &
'4a54G', &
'hSs6k'])) stop
astr5a6(:) = ['DDGhf', &
'hdrh$', &
'fDGSl', &
'DFHs3', &
'43grG', &
'hFG$k']
call a5ar (astr5a6)
if (any (astr5a6 /= ['FDGhf', &
'hdrhg', &
'fDgFl', &
'DFHs3', &
'4a54G', &
'hSs6k'])) stop
! pointer - with array descriptor
pstr5a6 = ['DDGhf', &
'hdrh$', &
'fDGSl', &
'DFHs3', &
'43grG', &
'hFG$k']
call a5p (pstr5a6)
if (any (pstr5a6 /= ['FDGhf', &
'hdrhg', &
'fDgFl', &
'DFHs3', &
'4a54G', &
'hSs6k'])) stop
pstr5a6 = ['DDGhf', &
'hdrh$', &
'fDGSl', &
'DFHs3', &
'43grG', &
'hFG$k']
call a5pr (pstr5a6)
if (any (pstr5a6 /= ['FDGhf', &
'hdrhg', &
'fDgFl', &
'DFHs3', &
'4a54G', &
'hSs6k'])) stop
deallocate (astr5a6, pstr5a6)
end
! All arguments shall use array descriptors
! { dg-final { scan-tree-dump-times "void as1 \\(struct array01_character\\(kind=1\\) & restrict x1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "void as2 \\(struct array01_character\\(kind=1\\) & restrict x2\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "void as4 \\(struct array01_character\\(kind=1\\) & restrict xstar\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "void as3 \\(struct array01_character\\(kind=1\\) & restrict xn, integer(kind=4) & restrict n)
! { dg-final { scan-tree-dump-times "void ar1 \\(struct array15_character\\(kind=1\\) & restrict x1\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "void ar2 \\(struct array15_character\\(kind=1\\) & restrict x2\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "void ar3 \\(struct array15_character\\(kind=1\\) & restrict xn, integer(kind=4) & restrict n)
! { dg-final { scan-tree-dump-times "void ar4 \\(struct array15_character\\(kind=1\\) & restrict xstar\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "void a5a \\(struct array01_character\\(kind=1\\) & restrict xcolon\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "void a5ar \\(struct array15_character\\(kind=1\\) & restrict xcolon\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "void a5p \\(struct array01_character\\(kind=1\\) & xcolon\\)" 1 "original" } }
! { dg-final { scan-tree-dump-times "void a5pr \\(struct array15_character\\(kind=1\\) & xcolon\\)" 1 "original" } }