blob: 3eb2732a368c1f8e04c0dbc7adf050d1de610abf [file] [log] [blame]
! { dg-do run }
! { dg-additional-sources bind-c-contiguous-5.c }
! { dg-additional-options "-fcheck=all" }
! { dg-prune-output "command-line option '-fcheck=.*' is valid for Fortran but not for C" }
! ---- Same as bind-c-contiguous-1.f90 - but with kind=4 characters
! Fortran demands that with bind(C), the callee ensure that for
! * 'contiguous'
! * len=* with explicit/assumed-size arrays
! noncontiguous actual arguments are handled.
! (in without bind(C) in gfortran, caller handles the copy in/out
! Additionally, for a bind(C) callee, a Fortran-written caller
! has to ensure the same (for contiguous + len=* to explicit-/assumed-size arrays)
module m
use iso_c_binding, only: c_intptr_t, c_bool, c_loc, c_int
implicit none (type, external)
type, bind(C) :: loc_t
integer(c_intptr_t) :: x, y, z
end type loc_t
interface
type(loc_t) function char_assumed_size_c (xx, yy, zz, n, num) bind(C)
import :: loc_t, c_bool, c_int
integer(c_int), value :: n, num
character(kind=4, len=*) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*)
end function
type(loc_t) function char_assumed_size_in_c (xx, yy, zz, n, num) bind(C)
import :: loc_t, c_bool, c_int
integer(c_int), value :: n, num
character(kind=4, len=*), intent(in) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*)
end function
type(loc_t) function char_expl_size_c (xx, yy, zz, n, num) bind(c)
import :: loc_t, c_bool, c_int
integer(c_int), value :: n, num
character(kind=4, len=*) :: xx(n), yy(n:n+3), zz(6:6, 3:n, 3:n+3)
end function
type(loc_t) function char_expl_size_in_c (xx, yy, zz, n, num) bind(c)
import :: loc_t, c_bool, c_int
integer(c_int), value :: n, num
character(kind=4, len=*), intent(in) :: xx(n), yy(n:n+3), zz(6:6, 3:n, 3:n+3)
end function
type(loc_t) function char_assumed_rank_c (xx, yy, zz, k, num) bind(c)
import :: loc_t, c_bool, c_int
integer, value :: k, num
character(kind=4, len=*) :: xx(..)
character(kind=4, len=3) :: yy(..)
character(kind=4, len=k) :: zz(..)
end function
type(loc_t) function char_assumed_rank_in_c (xx, yy, zz, k, num) bind(c)
import :: loc_t, c_bool, c_int
integer, value :: k, num
character(kind=4, len=*), intent(in) :: xx(..)
character(kind=4, len=3), intent(in) :: yy(..)
character(kind=4, len=k), intent(in) :: zz(..)
end function
type(loc_t) function char_assumed_rank_cont_c (xx, yy, zz, k, num) bind(c)
import :: loc_t, c_bool, c_int
integer, value :: k, num
character(kind=4, len=*), contiguous :: xx(..)
character(kind=4, len=3), contiguous :: yy(..)
character(kind=4, len=k), contiguous :: zz(..)
end function
type(loc_t) function char_assumed_rank_cont_in_c (xx, yy, zz, k, num) bind(c)
import :: loc_t, c_bool, c_int
integer, value :: k, num
character(kind=4, len=*), contiguous, intent(in) :: xx(..)
character(kind=4, len=3), contiguous, intent(in) :: yy(..)
character(kind=4, len=k), contiguous, intent(in) :: zz(..)
end function
type(loc_t) function char_assumed_shape_c (xx, yy, zz, k, num) bind(c)
import :: loc_t, c_bool, c_int
integer, value :: k, num
character(kind=4, len=*) :: xx(:)
character(kind=4, len=3) :: yy(5:)
character(kind=4, len=k) :: zz(-k:)
end function
type(loc_t) function char_assumed_shape_in_c (xx, yy, zz, k, num) bind(c)
import :: loc_t, c_bool, c_int
integer, value :: k, num
character(kind=4, len=*), intent(in) :: xx(:)
character(kind=4, len=3), intent(in) :: yy(5:)
character(kind=4, len=k), intent(in) :: zz(-k:)
end function
type(loc_t) function char_assumed_shape_cont_c (xx, yy, zz, k, num) bind(c)
import :: loc_t, c_bool, c_int
integer, value :: k, num
character(kind=4, len=*), contiguous :: xx(:)
character(kind=4, len=3), contiguous :: yy(5:)
character(kind=4, len=k), contiguous :: zz(-k:)
end function
type(loc_t) function char_assumed_shape_cont_in_c (xx, yy, zz, k, num) bind(c)
import :: loc_t, c_bool, c_int
integer, value :: k, num
character(kind=4, len=*), contiguous, intent(in) :: xx(:)
character(kind=4, len=3), contiguous, intent(in) :: yy(5:)
character(kind=4, len=k), contiguous, intent(in) :: zz(-k:)
end function
end interface
contains
type(loc_t) function char_assumed_size_f (xx, yy, zz, n, num) bind(c) result(res)
integer, value :: num, n
character(kind=4, len=*) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*)
print *, xx(1:3)
if (3 /= len(xx)) error stop 1
if (3 /= len(yy)) error stop 1
if (3 /= len(zz)) error stop 1
if (1 /= lbound(xx,dim=1)) error stop 1
if (3 /= lbound(yy,dim=1)) error stop 1
if (6 /= lbound(zz,dim=1)) error stop 1
if (3 /= lbound(zz,dim=2)) error stop 1
if (3 /= lbound(zz,dim=3)) error stop 1
if (1 /= size(zz,dim=1)) error stop 1
if (1 /= size(zz,dim=2)) error stop 1
if (6 /= ubound(zz,dim=1)) error stop 1
if (3 /= ubound(zz,dim=2)) error stop 1
if (num == 1) then
if (xx(1) /= 4_"abc") error stop 2
if (xx(2) /= 4_"ghi") error stop 3
if (xx(3) /= 4_"nop") error stop 4
if (yy(3) /= 4_"abc") error stop 2
if (yy(4) /= 4_"ghi") error stop 3
if (yy(5) /= 4_"nop") error stop 4
if (zz(6,n,3) /= 4_"abc") error stop 2
if (zz(6,n,4) /= 4_"ghi") error stop 3
if (zz(6,n,5) /= 4_"nop") error stop 4
else if (num == 2) then
if (xx(1) /= 4_"def") error stop 2
if (xx(2) /= 4_"ghi") error stop 3
if (xx(3) /= 4_"jlm") error stop 4
if (yy(3) /= 4_"def") error stop 2
if (yy(4) /= 4_"ghi") error stop 3
if (yy(5) /= 4_"jlm") error stop 4
if (zz(6,n,3) /= 4_"def") error stop 2
if (zz(6,n,4) /= 4_"ghi") error stop 3
if (zz(6,n,5) /= 4_"jlm") error stop 4
else
error stop 8
endif
xx(1) = 4_"ABC"
xx(2) = 4_"DEF"
xx(3) = 4_"GHI"
yy(3) = 4_"ABC"
yy(4) = 4_"DEF"
yy(5) = 4_"GHI"
zz(6,n,3) = 4_"ABC"
zz(6,n,4) = 4_"DEF"
zz(6,n,5) = 4_"GHI"
res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
end
type(loc_t) function char_assumed_size_in_f (xx, yy, zz, n, num) bind(c) result(res)
integer, value :: num, n
character(kind=4, len=*) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*)
intent(in) :: xx, yy, zz
print *, xx(1:3)
if (3 /= len(xx)) error stop 1
if (3 /= len(yy)) error stop 1
if (3 /= len(zz)) error stop 1
if (1 /= lbound(xx,dim=1)) error stop 1
if (3 /= lbound(yy,dim=1)) error stop 1
if (6 /= lbound(zz,dim=1)) error stop 1
if (3 /= lbound(zz,dim=2)) error stop 1
if (3 /= lbound(zz,dim=3)) error stop 1
if (1 /= size(zz,dim=1)) error stop 1
if (1 /= size(zz,dim=2)) error stop 1
if (6 /= ubound(zz,dim=1)) error stop 1
if (3 /= ubound(zz,dim=2)) error stop 1
if (num == 1) then
if (xx(1) /= 4_"abc") error stop 2
if (xx(2) /= 4_"ghi") error stop 3
if (xx(3) /= 4_"nop") error stop 4
if (yy(3) /= 4_"abc") error stop 2
if (yy(4) /= 4_"ghi") error stop 3
if (yy(5) /= 4_"nop") error stop 4
if (zz(6,n,3) /= 4_"abc") error stop 2
if (zz(6,n,4) /= 4_"ghi") error stop 3
if (zz(6,n,5) /= 4_"nop") error stop 4
else if (num == 2) then
if (xx(1) /= 4_"def") error stop 2
if (xx(2) /= 4_"ghi") error stop 3
if (xx(3) /= 4_"jlm") error stop 4
if (yy(3) /= 4_"def") error stop 2
if (yy(4) /= 4_"ghi") error stop 3
if (yy(5) /= 4_"jlm") error stop 4
if (zz(6,n,3) /= 4_"def") error stop 2
if (zz(6,n,4) /= 4_"ghi") error stop 3
if (zz(6,n,5) /= 4_"jlm") error stop 4
else
error stop 8
endif
res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
res%z = %loc(zz) ! { dg-warning "Legacy Extension" } if (num == 1) then
end
type(loc_t) function char_expl_size_f (xx, yy, zz, n, num) bind(c) result(res)
integer, value :: num, n
character(kind=4, len=*) :: xx(n), yy(n:n+2), zz(6:6, 3:n, 3:n+2)
print *, xx(1:3)
if (3 /= len(xx)) error stop 1
if (3 /= len(yy)) error stop 1
if (3 /= len(zz)) error stop 1
if (1 /= lbound(xx,dim=1)) error stop 1
if (3 /= lbound(yy,dim=1)) error stop 1
if (6 /= lbound(zz,dim=1)) error stop 1
if (3 /= lbound(zz,dim=2)) error stop 1
if (3 /= lbound(zz,dim=3)) error stop 1
if (3 /= size(xx,dim=1)) error stop 1
if (3 /= size(yy,dim=1)) error stop 1
if (1 /= size(zz,dim=1)) error stop 1
if (1 /= size(zz,dim=2)) error stop 1
if (3 /= size(zz,dim=3)) error stop 1
if (3 /= ubound(xx,dim=1)) error stop 1
if (5 /= ubound(yy,dim=1)) error stop 1
if (6 /= ubound(zz,dim=1)) error stop 1
if (3 /= ubound(zz,dim=2)) error stop 1
if (5 /= ubound(zz,dim=3)) error stop 1
if (num == 1) then
if (xx(1) /= 4_"abc") error stop 2
if (xx(2) /= 4_"ghi") error stop 3
if (xx(3) /= 4_"nop") error stop 4
if (yy(3) /= 4_"abc") error stop 2
if (yy(4) /= 4_"ghi") error stop 3
if (yy(5) /= 4_"nop") error stop 4
if (zz(6,n,3) /= 4_"abc") error stop 2
if (zz(6,n,4) /= 4_"ghi") error stop 3
if (zz(6,n,5) /= 4_"nop") error stop 4
else if (num == 2) then
if (xx(1) /= 4_"def") error stop 2
if (xx(2) /= 4_"ghi") error stop 3
if (xx(3) /= 4_"jlm") error stop 4
if (yy(3) /= 4_"def") error stop 2
if (yy(4) /= 4_"ghi") error stop 3
if (yy(5) /= 4_"jlm") error stop 4
if (zz(6,n,3) /= 4_"def") error stop 2
if (zz(6,n,4) /= 4_"ghi") error stop 3
if (zz(6,n,5) /= 4_"jlm") error stop 4
else
error stop 8
endif
xx(1) = 4_"ABC"
xx(2) = 4_"DEF"
xx(3) = 4_"GHI"
yy(3) = 4_"ABC"
yy(4) = 4_"DEF"
yy(5) = 4_"GHI"
zz(6,n,3) = 4_"ABC"
zz(6,n,4) = 4_"DEF"
zz(6,n,5) = 4_"GHI"
res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
end
type(loc_t) function char_expl_size_in_f (xx, yy, zz, n, num) bind(c) result(res)
integer, value :: num, n
character(kind=4, len=*) :: xx(n), yy(n:n+2), zz(6:6, 3:n, 3:n+2)
intent(in) :: xx, yy, zz
print *, xx(1:3)
if (3 /= len(xx)) error stop 1
if (3 /= len(yy)) error stop 1
if (3 /= len(zz)) error stop 1
if (1 /= lbound(xx,dim=1)) error stop 1
if (3 /= lbound(yy,dim=1)) error stop 1
if (6 /= lbound(zz,dim=1)) error stop 1
if (3 /= lbound(zz,dim=2)) error stop 1
if (3 /= lbound(zz,dim=3)) error stop 1
if (3 /= size(xx,dim=1)) error stop 1
if (3 /= size(yy,dim=1)) error stop 1
if (1 /= size(zz,dim=1)) error stop 1
if (1 /= size(zz,dim=2)) error stop 1
if (3 /= size(zz,dim=3)) error stop 1
if (3 /= ubound(xx,dim=1)) error stop 1
if (5 /= ubound(yy,dim=1)) error stop 1
if (6 /= ubound(zz,dim=1)) error stop 1
if (3 /= ubound(zz,dim=2)) error stop 1
if (5 /= ubound(zz,dim=3)) error stop 1
if (num == 1) then
if (xx(1) /= 4_"abc") error stop 2
if (xx(2) /= 4_"ghi") error stop 3
if (xx(3) /= 4_"nop") error stop 4
if (yy(3) /= 4_"abc") error stop 2
if (yy(4) /= 4_"ghi") error stop 3
if (yy(5) /= 4_"nop") error stop 4
if (zz(6,n,3) /= 4_"abc") error stop 2
if (zz(6,n,4) /= 4_"ghi") error stop 3
if (zz(6,n,5) /= 4_"nop") error stop 4
else if (num == 2) then
if (xx(1) /= 4_"def") error stop 2
if (xx(2) /= 4_"ghi") error stop 3
if (xx(3) /= 4_"jlm") error stop 4
if (yy(3) /= 4_"def") error stop 2
if (yy(4) /= 4_"ghi") error stop 3
if (yy(5) /= 4_"jlm") error stop 4
if (zz(6,n,3) /= 4_"def") error stop 2
if (zz(6,n,4) /= 4_"ghi") error stop 3
if (zz(6,n,5) /= 4_"jlm") error stop 4
else
error stop 8
endif
res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
end
type(loc_t) function char_assumed_rank_f (xx, yy, zz, k, num) bind(c) result(res)
integer, value :: num, k
character(kind=4, len=*) :: xx(..)
character(kind=4, len=3) :: yy(..)
character(kind=4, len=k) :: zz(..)
if (3 /= len(xx)) error stop 40
if (3 /= len(yy)) error stop 40
if (3 /= len(zz)) error stop 40
if (3 /= size(xx)) error stop 41
if (3 /= size(yy)) error stop 41
if (3 /= size(zz)) error stop 41
if (1 /= rank(xx)) error stop 49
if (1 /= rank(yy)) error stop 49
if (1 /= rank(zz)) error stop 49
if (1 /= lbound(xx, dim=1)) stop 49
if (1 /= lbound(yy, dim=1)) stop 49
if (1 /= lbound(zz, dim=1)) stop 49
if (3 /= ubound(xx, dim=1)) stop 49
if (3 /= ubound(yy, dim=1)) stop 49
if (3 /= ubound(zz, dim=1)) stop 49
if (num == 1) then
if (is_contiguous (xx)) error stop 49
if (is_contiguous (yy)) error stop 49
if (is_contiguous (zz)) error stop 49
else if (num == 2) then
if (.not. is_contiguous (xx)) error stop 49
if (.not. is_contiguous (yy)) error stop 49
if (.not. is_contiguous (zz)) error stop 49
else
error stop 48
end if
select rank (xx)
rank (1)
print *, xx(1:3)
if (num == 1) then
if (xx(1) /= 4_"abc") error stop 42
if (xx(2) /= 4_"ghi") error stop 43
if (xx(3) /= 4_"nop") error stop 44
else if (num == 2) then
if (xx(1) /= 4_"def") error stop 45
if (xx(2) /= 4_"ghi") error stop 46
if (xx(3) /= 4_"jlm") error stop 47
else
error stop 48
endif
xx(1) = 4_"ABC"
xx(2) = 4_"DEF"
xx(3) = 4_"GHI"
res%x = get_loc (xx)
rank default
error stop 99
end select
select rank (yy)
rank (1)
print *, yy(1:3)
if (num == 1) then
if (yy(1) /= 4_"abc") error stop 42
if (yy(2) /= 4_"ghi") error stop 43
if (yy(3) /= 4_"nop") error stop 44
else if (num == 2) then
if (yy(1) /= 4_"def") error stop 45
if (yy(2) /= 4_"ghi") error stop 46
if (yy(3) /= 4_"jlm") error stop 47
else
error stop 48
endif
yy(1) = 4_"ABC"
yy(2) = 4_"DEF"
yy(3) = 4_"GHI"
res%y = get_loc (yy)
rank default
error stop 99
end select
select rank (zz)
rank (1)
print *, zz(1:3)
if (num == 1) then
if (zz(1) /= 4_"abc") error stop 42
if (zz(2) /= 4_"ghi") error stop 43
if (zz(3) /= 4_"nop") error stop 44
else if (num == 2) then
if (zz(1) /= 4_"def") error stop 45
if (zz(2) /= 4_"ghi") error stop 46
if (zz(3) /= 4_"jlm") error stop 47
else
error stop 48
endif
zz(1) = 4_"ABC"
zz(2) = 4_"DEF"
zz(3) = 4_"GHI"
res%z = get_loc (zz)
rank default
error stop 99
end select
contains
integer (c_intptr_t) function get_loc (arg)
character(kind=4, len=*), target :: arg(:)
! %loc does copy in/out if not simply contiguous
! extra func needed because of 'target' attribute
get_loc = transfer (c_loc(arg), res%x)
end
end
type(loc_t) function char_assumed_rank_in_f (xx, yy, zz, k, num) bind(c) result(res)
integer, value :: num, k
character(kind=4, len=*) :: xx(..)
character(kind=4, len=3) :: yy(..)
character(kind=4, len=k) :: zz(..)
intent(in) :: xx, yy, zz
if (3 /= size(yy)) error stop 50
if (3 /= len(yy)) error stop 51
if (1 /= rank(yy)) error stop 59
if (1 /= lbound(xx, dim=1)) stop 49
if (1 /= lbound(yy, dim=1)) stop 49
if (1 /= lbound(zz, dim=1)) stop 49
if (3 /= ubound(xx, dim=1)) stop 49
if (3 /= ubound(yy, dim=1)) stop 49
if (3 /= ubound(zz, dim=1)) stop 49
if (num == 1) then
if (is_contiguous (xx)) error stop 59
if (is_contiguous (yy)) error stop 59
if (is_contiguous (zz)) error stop 59
else if (num == 2) then
if (.not. is_contiguous (xx)) error stop 59
if (.not. is_contiguous (yy)) error stop 59
if (.not. is_contiguous (zz)) error stop 59
else
error stop 48
end if
select rank (xx)
rank (1)
print *, xx(1:3)
if (num == 1) then
if (xx(1) /= 4_"abc") error stop 52
if (xx(2) /= 4_"ghi") error stop 53
if (xx(3) /= 4_"nop") error stop 54
else if (num == 2) then
if (xx(1) /= 4_"def") error stop 55
if (xx(2) /= 4_"ghi") error stop 56
if (xx(3) /= 4_"jlm") error stop 57
else
error stop 58
endif
res%x = get_loc(xx)
rank default
error stop 99
end select
select rank (yy)
rank (1)
print *, yy(1:3)
if (num == 1) then
if (yy(1) /= 4_"abc") error stop 52
if (yy(2) /= 4_"ghi") error stop 53
if (yy(3) /= 4_"nop") error stop 54
else if (num == 2) then
if (yy(1) /= 4_"def") error stop 55
if (yy(2) /= 4_"ghi") error stop 56
if (yy(3) /= 4_"jlm") error stop 57
else
error stop 58
endif
res%y = get_loc(yy)
rank default
error stop 99
end select
select rank (zz)
rank (1)
print *, zz(1:3)
if (num == 1) then
if (zz(1) /= 4_"abc") error stop 52
if (zz(2) /= 4_"ghi") error stop 53
if (zz(3) /= 4_"nop") error stop 54
else if (num == 2) then
if (zz(1) /= 4_"def") error stop 55
if (zz(2) /= 4_"ghi") error stop 56
if (zz(3) /= 4_"jlm") error stop 57
else
error stop 58
endif
res%z = get_loc(zz)
rank default
error stop 99
end select
contains
integer (c_intptr_t) function get_loc (arg)
character(kind=4, len=*), target :: arg(:)
! %loc does copy in/out if not simply contiguous
! extra func needed because of 'target' attribute
get_loc = transfer (c_loc(arg), res%x)
end
end
type(loc_t) function char_assumed_rank_cont_f (xx, yy, zz, k, num) bind(c) result(res)
integer, value :: num, k
character(kind=4, len=*) :: xx(..)
character(kind=4, len=3) :: yy(..)
character(kind=4, len=k) :: zz(..)
contiguous :: xx, yy, zz
if (3 /= len(xx)) error stop 60
if (3 /= len(yy)) error stop 60
if (3 /= len(zz)) error stop 60
if (3 /= size(xx)) error stop 61
if (3 /= size(yy)) error stop 61
if (3 /= size(zz)) error stop 61
if (1 /= rank(xx)) error stop 69
if (1 /= rank(yy)) error stop 69
if (1 /= rank(zz)) error stop 69
if (1 /= lbound(xx, dim=1)) stop 49
if (1 /= lbound(yy, dim=1)) stop 49
if (1 /= lbound(zz, dim=1)) stop 49
if (3 /= ubound(xx, dim=1)) stop 49
if (3 /= ubound(yy, dim=1)) stop 49
if (3 /= ubound(zz, dim=1)) stop 49
select rank (xx)
rank (1)
print *, xx(1:3)
if (num == 1) then
if (xx(1) /= 4_"abc") error stop 62
if (xx(2) /= 4_"ghi") error stop 63
if (xx(3) /= 4_"nop") error stop 64
else if (num == 2) then
if (xx(1) /= 4_"def") error stop 65
if (xx(2) /= 4_"ghi") error stop 66
if (xx(3) /= 4_"jlm") error stop 67
else
error stop 68
endif
xx(1) = 4_"ABC"
xx(2) = 4_"DEF"
xx(3) = 4_"GHI"
res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
rank default
error stop 99
end select
select rank (yy)
rank (1)
print *, yy(1:3)
if (num == 1) then
if (yy(1) /= 4_"abc") error stop 62
if (yy(2) /= 4_"ghi") error stop 63
if (yy(3) /= 4_"nop") error stop 64
else if (num == 2) then
if (yy(1) /= 4_"def") error stop 65
if (yy(2) /= 4_"ghi") error stop 66
if (yy(3) /= 4_"jlm") error stop 67
else
error stop 68
endif
yy(1) = 4_"ABC"
yy(2) = 4_"DEF"
yy(3) = 4_"GHI"
res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
rank default
error stop 99
end select
select rank (zz)
rank (1)
print *, zz(1:3)
if (num == 1) then
if (zz(1) /= 4_"abc") error stop 62
if (zz(2) /= 4_"ghi") error stop 63
if (zz(3) /= 4_"nop") error stop 64
else if (num == 2) then
if (zz(1) /= 4_"def") error stop 65
if (zz(2) /= 4_"ghi") error stop 66
if (zz(3) /= 4_"jlm") error stop 67
else
error stop 68
endif
zz(1) = 4_"ABC"
zz(2) = 4_"DEF"
zz(3) = 4_"GHI"
res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
rank default
error stop 99
end select
end
type(loc_t) function char_assumed_rank_cont_in_f (xx, yy, zz, k, num) bind(c) result(res)
integer, value :: num, k
character(kind=4, len=*) :: xx(..)
character(kind=4, len=3) :: yy(..)
character(kind=4, len=k) :: zz(..)
intent(in) :: xx, yy, zz
contiguous :: xx, yy, zz
if (3 /= size(xx)) error stop 30
if (3 /= size(yy)) error stop 30
if (3 /= size(zz)) error stop 30
if (3 /= len(xx)) error stop 31
if (3 /= len(yy)) error stop 31
if (3 /= len(zz)) error stop 31
if (1 /= rank(xx)) error stop 69
if (1 /= rank(yy)) error stop 69
if (1 /= rank(zz)) error stop 69
if (1 /= lbound(xx, dim=1)) stop 49
if (1 /= lbound(yy, dim=1)) stop 49
if (1 /= lbound(zz, dim=1)) stop 49
if (3 /= ubound(xx, dim=1)) stop 49
if (3 /= ubound(yy, dim=1)) stop 49
if (3 /= ubound(zz, dim=1)) stop 49
select rank (xx)
rank (1)
print *, xx(1:3)
if (num == 1) then
if (xx(1) /= 4_"abc") error stop 62
if (xx(2) /= 4_"ghi") error stop 63
if (xx(3) /= 4_"nop") error stop 64
else if (num == 2) then
if (xx(1) /= 4_"def") error stop 65
if (xx(2) /= 4_"ghi") error stop 66
if (xx(3) /= 4_"jlm") error stop 67
else
error stop 68
endif
res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
rank default
error stop 99
end select
select rank (yy)
rank (1)
print *, yy(1:3)
if (num == 1) then
if (yy(1) /= 4_"abc") error stop 62
if (yy(2) /= 4_"ghi") error stop 63
if (yy(3) /= 4_"nop") error stop 64
else if (num == 2) then
if (yy(1) /= 4_"def") error stop 65
if (yy(2) /= 4_"ghi") error stop 66
if (yy(3) /= 4_"jlm") error stop 67
else
error stop 68
endif
res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
rank default
error stop 99
end select
select rank (zz)
rank (1)
print *, zz(1:3)
if (num == 1) then
if (zz(1) /= 4_"abc") error stop 62
if (zz(2) /= 4_"ghi") error stop 63
if (zz(3) /= 4_"nop") error stop 64
else if (num == 2) then
if (zz(1) /= 4_"def") error stop 65
if (zz(2) /= 4_"ghi") error stop 66
if (zz(3) /= 4_"jlm") error stop 67
else
error stop 68
endif
res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
rank default
error stop 99
end select
end
type(loc_t) function char_assumed_shape_f (xx, yy, zz, k, num) bind(c) result(res)
integer, value :: num, k
character(kind=4, len=*) :: xx(:)
character(kind=4, len=3) :: yy(5:)
character(kind=4, len=k) :: zz(-k:)
print *, xx(1:3)
if (3 /= len(xx)) error stop 70
if (3 /= len(yy)) error stop 70
if (3 /= len(zz)) error stop 70
if (3 /= size(xx)) error stop 71
if (3 /= size(yy)) error stop 71
if (3 /= size(zz)) error stop 71
if (1 /= lbound(xx, dim=1)) stop 49
if (5 /= lbound(yy, dim=1)) stop 49
if (-k /= lbound(zz, dim=1)) stop 49
if (3 /= ubound(xx, dim=1)) stop 49
if (7 /= ubound(yy, dim=1)) stop 49
if (-k+2 /= ubound(zz, dim=1)) stop 49
if (num == 1) then
if (is_contiguous (xx)) error stop 79
if (is_contiguous (yy)) error stop 79
if (is_contiguous (zz)) error stop 79
if (xx(1) /= 4_"abc") error stop 72
if (xx(2) /= 4_"ghi") error stop 73
if (xx(3) /= 4_"nop") error stop 74
if (yy(5) /= 4_"abc") error stop 72
if (yy(6) /= 4_"ghi") error stop 73
if (yy(7) /= 4_"nop") error stop 74
if (zz(-k) /= 4_"abc") error stop 72
if (zz(-k+1) /= 4_"ghi") error stop 73
if (zz(-k+2) /= 4_"nop") error stop 74
else if (num == 2) then
if (.not.is_contiguous (xx)) error stop 79
if (.not.is_contiguous (yy)) error stop 79
if (.not.is_contiguous (zz)) error stop 79
if (xx(1) /= 4_"def") error stop 72
if (xx(2) /= 4_"ghi") error stop 73
if (xx(3) /= 4_"jlm") error stop 74
if (yy(5) /= 4_"def") error stop 72
if (yy(6) /= 4_"ghi") error stop 73
if (yy(7) /= 4_"jlm") error stop 74
if (zz(-k) /= 4_"def") error stop 72
if (zz(-k+1) /= 4_"ghi") error stop 73
if (zz(-k+2) /= 4_"jlm") error stop 74
else
error stop 78
endif
xx(1) = 4_"ABC"
xx(2) = 4_"DEF"
xx(3) = 4_"GHI"
yy(5) = 4_"ABC"
yy(6) = 4_"DEF"
yy(7) = 4_"GHI"
zz(-k) = 4_"ABC"
zz(-k+1) = 4_"DEF"
zz(-k+2) = 4_"GHI"
res%x = get_loc(xx)
res%y = get_loc(yy)
res%z = get_loc(zz)
contains
integer (c_intptr_t) function get_loc (arg)
character(kind=4, len=*), target :: arg(:)
! %loc does copy in/out if not simply contiguous
! extra func needed because of 'target' attribute
get_loc = transfer (c_loc(arg), res%x)
end
end
type(loc_t) function char_assumed_shape_in_f (xx, yy, zz, k, num) bind(c) result(res)
integer, value :: num, k
character(kind=4, len=*) :: xx(:)
character(kind=4, len=3) :: yy(5:)
character(kind=4, len=k) :: zz(-k:)
intent(in) :: xx, yy, zz
print *, xx(1:3)
if (3 /= size(xx)) error stop 80
if (3 /= size(yy)) error stop 80
if (3 /= size(zz)) error stop 80
if (3 /= len(xx)) error stop 81
if (3 /= len(yy)) error stop 81
if (3 /= len(zz)) error stop 81
if (1 /= lbound(xx, dim=1)) stop 49
if (5 /= lbound(yy, dim=1)) stop 49
if (-k /= lbound(zz, dim=1)) stop 49
if (3 /= ubound(xx, dim=1)) stop 49
if (7 /= ubound(yy, dim=1)) stop 49
if (-k+2 /= ubound(zz, dim=1)) stop 49
if (num == 1) then
if (is_contiguous (xx)) error stop 89
if (is_contiguous (yy)) error stop 89
if (is_contiguous (zz)) error stop 89
if (xx(1) /= 4_"abc") error stop 82
if (xx(2) /= 4_"ghi") error stop 83
if (xx(3) /= 4_"nop") error stop 84
if (yy(5) /= 4_"abc") error stop 82
if (yy(6) /= 4_"ghi") error stop 83
if (yy(7) /= 4_"nop") error stop 84
if (zz(-k) /= 4_"abc") error stop 82
if (zz(-k+1) /= 4_"ghi") error stop 83
if (zz(-k+2) /= 4_"nop") error stop 84
else if (num == 2) then
if (.not.is_contiguous (xx)) error stop 89
if (.not.is_contiguous (yy)) error stop 89
if (.not.is_contiguous (zz)) error stop 89
if (xx(1) /= 4_"def") error stop 85
if (xx(2) /= 4_"ghi") error stop 86
if (xx(3) /= 4_"jlm") error stop 87
if (yy(5) /= 4_"def") error stop 85
if (yy(6) /= 4_"ghi") error stop 86
if (yy(7) /= 4_"jlm") error stop 87
if (zz(-k) /= 4_"def") error stop 85
if (zz(-k+1) /= 4_"ghi") error stop 86
if (zz(-k+2) /= 4_"jlm") error stop 87
else
error stop 88
endif
res%x = get_loc(xx)
res%y = get_loc(yy)
res%z = get_loc(zz)
contains
integer (c_intptr_t) function get_loc (arg)
character(kind=4, len=*), target :: arg(:)
! %loc does copy in/out if not simply contiguous
! extra func needed because of 'target' attribute
get_loc = transfer (c_loc(arg), res%x)
end
end
type(loc_t) function char_assumed_shape_cont_f (xx, yy, zz, k, num) bind(c) result(res)
integer, value :: num, k
character(kind=4, len=*) :: xx(:)
character(kind=4, len=3) :: yy(5:)
character(kind=4, len=k) :: zz(-k:)
contiguous :: xx, yy, zz
print *, xx(1:3)
if (3 /= len(xx)) error stop 90
if (3 /= len(yy)) error stop 90
if (3 /= len(zz)) error stop 90
if (3 /= size(xx)) error stop 91
if (3 /= size(yy)) error stop 91
if (3 /= size(zz)) error stop 91
if (1 /= lbound(xx, dim=1)) stop 49
if (5 /= lbound(yy, dim=1)) stop 49
if (-k /= lbound(zz, dim=1)) stop 49
if (3 /= ubound(xx, dim=1)) stop 49
if (7 /= ubound(yy, dim=1)) stop 49
if (-k+2 /= ubound(zz, dim=1)) stop 49
if (num == 1) then
if (xx(1) /= 4_"abc") error stop 92
if (xx(2) /= 4_"ghi") error stop 93
if (xx(3) /= 4_"nop") error stop 94
if (yy(5) /= 4_"abc") error stop 92
if (yy(6) /= 4_"ghi") error stop 93
if (yy(7) /= 4_"nop") error stop 94
if (zz(-k) /= 4_"abc") error stop 92
if (zz(-k+1) /= 4_"ghi") error stop 93
if (zz(-k+2) /= 4_"nop") error stop 94
else if (num == 2) then
if (xx(1) /= 4_"def") error stop 92
if (xx(2) /= 4_"ghi") error stop 93
if (xx(3) /= 4_"jlm") error stop 94
if (yy(5) /= 4_"def") error stop 92
if (yy(6) /= 4_"ghi") error stop 93
if (yy(7) /= 4_"jlm") error stop 94
if (zz(-k) /= 4_"def") error stop 92
if (zz(-k+1) /= 4_"ghi") error stop 93
if (zz(-k+2) /= 4_"jlm") error stop 94
else
error stop 98
endif
xx(1) = 4_"ABC"
xx(2) = 4_"DEF"
xx(3) = 4_"GHI"
yy(5) = 4_"ABC"
yy(6) = 4_"DEF"
yy(7) = 4_"GHI"
zz(-k) = 4_"ABC"
zz(-k+1) = 4_"DEF"
zz(-k+2) = 4_"GHI"
res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
end
type(loc_t) function char_assumed_shape_cont_in_f (xx, yy, zz, k, num) bind(c) result(res)
integer, value :: num, k
character(kind=4, len=*) :: xx(:)
character(kind=4, len=3) :: yy(5:)
character(kind=4, len=k) :: zz(-k:)
intent(in) :: xx, yy, zz
contiguous :: xx, yy, zz
print *, xx(1:3)
if (3 /= size(xx)) error stop 100
if (3 /= size(yy)) error stop 100
if (3 /= size(zz)) error stop 100
if (3 /= len(xx)) error stop 101
if (3 /= len(yy)) error stop 101
if (3 /= len(zz)) error stop 101
if (1 /= lbound(xx, dim=1)) stop 49
if (5 /= lbound(yy, dim=1)) stop 49
if (-k /= lbound(zz, dim=1)) stop 49
if (3 /= ubound(xx, dim=1)) stop 49
if (7 /= ubound(yy, dim=1)) stop 49
if (-k+2 /= ubound(zz, dim=1)) stop 49
if (num == 1) then
if (xx(1) /= 4_"abc") error stop 102
if (xx(2) /= 4_"ghi") error stop 103
if (xx(3) /= 4_"nop") error stop 104
if (yy(5) /= 4_"abc") error stop 102
if (yy(6) /= 4_"ghi") error stop 103
if (yy(7) /= 4_"nop") error stop 104
if (zz(-k) /= 4_"abc") error stop 102
if (zz(-k+1) /= 4_"ghi") error stop 103
if (zz(-k+2) /= 4_"nop") error stop 104
else if (num == 2) then
if (xx(1) /= 4_"def") error stop 105
if (xx(2) /= 4_"ghi") error stop 106
if (xx(3) /= 4_"jlm") error stop 107
if (yy(5) /= 4_"def") error stop 105
if (yy(6) /= 4_"ghi") error stop 106
if (yy(7) /= 4_"jlm") error stop 107
if (zz(-k) /= 4_"def") error stop 105
if (zz(-k+1) /= 4_"ghi") error stop 106
if (zz(-k+2) /= 4_"jlm") error stop 107
else
error stop 108
endif
res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
end
end module
use m
implicit none (type, external)
character(kind=4, len=3) :: a(6), a2(6), a3(6), a_init(6)
type(loc_t) :: loc3
a_init = [4_'abc', 4_'def', 4_'ghi', 4_'jlm', 4_'nop', 4_'qrs']
! -- Fortran: assumed size
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_size_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_size_f (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2)
if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_size_in_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
if (any (a /= a_init)) error stop 56
if (any (a2 /= a_init)) error stop 58
if (any (a3 /= a_init)) error stop 58
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_size_in_f (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2)
if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
if (any (a /= a_init)) error stop 58
if (any (a2 /= a_init)) error stop 58
if (any (a3 /= a_init)) error stop 58
! -- Fortran: explicit shape
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_expl_size_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_expl_size_f (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2)
if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_expl_size_in_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
if (any (a /= a_init)) error stop 56
if (any (a2 /= a_init)) error stop 58
if (any (a3 /= a_init)) error stop 58
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_expl_size_in_f (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2)
if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
if (any (a /= a_init)) error stop 58
if (any (a2 /= a_init)) error stop 58
if (any (a3 /= a_init)) error stop 58
! -- Fortran: assumed rank
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_rank_f (a(::2), a2(::2), a3(::2), len(a), num=1)
if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_rank_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_rank_in_f (a(::2), a2(::2), a3(::2), len(a), num=1)
if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
if (any (a /= a_init)) error stop 56
if (any (a2 /= a_init)) error stop 56
if (any (a3 /= a_init)) error stop 56
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_rank_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
if (any (a /= a_init)) error stop 58
if (any (a2 /= a_init)) error stop 58
if (any (a3 /= a_init)) error stop 58
! -- Fortran: assumed rank contiguous
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_rank_cont_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_rank_cont_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_rank_cont_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
if (any (a /= a_init)) error stop 56
if (any (a2 /= a_init)) error stop 56
if (any (a3 /= a_init)) error stop 56
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_rank_cont_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
if (any (a /= a_init)) error stop 58
if (any (a2 /= a_init)) error stop 58
if (any (a3 /= a_init)) error stop 58
! -- Fortran: assumed shape
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_shape_f (a(::2), a2(::2), a3(::2), len(a), num=1)
if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_shape_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_shape_in_f (a(::2), a2(::2), a3(::2), len(a), num=1)
if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
if (any (a /= a_init)) error stop 56
if (any (a2 /= a_init)) error stop 56
if (any (a3 /= a_init)) error stop 56
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_shape_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
if (any (a /= a_init)) error stop 58
if (any (a2 /= a_init)) error stop 58
if (any (a3 /= a_init)) error stop 58
! -- Fortran: assumed shape contiguous
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_shape_cont_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_shape_cont_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_shape_cont_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
if (any (a /= a_init)) error stop 56
if (any (a2 /= a_init)) error stop 56
if (any (a3 /= a_init)) error stop 56
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_shape_cont_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
if (any (a /= a_init)) error stop 58
if (any (a2 /= a_init)) error stop 58
if (any (a3 /= a_init)) error stop 58
! --- character - call C directly --
! -- C: assumed size
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_size_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_size_c (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2)
if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_size_in_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
if (any (a /= a_init)) error stop 56
if (any (a2 /= a_init)) error stop 58
if (any (a3 /= a_init)) error stop 58
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_size_in_c (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2)
if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
if (any (a /= a_init)) error stop 58
if (any (a2 /= a_init)) error stop 58
if (any (a3 /= a_init)) error stop 58
! -- C: explicit shape
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_expl_size_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_expl_size_c (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2)
if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_expl_size_in_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
if (any (a /= a_init)) error stop 56
if (any (a2 /= a_init)) error stop 58
if (any (a3 /= a_init)) error stop 58
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_expl_size_in_c (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2)
if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
if (any (a /= a_init)) error stop 58
if (any (a2 /= a_init)) error stop 58
if (any (a3 /= a_init)) error stop 58
! -- C: assumed rank
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_rank_c (a(::2), a2(::2), a3(::2), len(a), num=1)
if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_rank_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_rank_in_c (a(::2), a2(::2), a3(::2), len(a), num=1)
if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
if (any (a /= a_init)) error stop 56
if (any (a2 /= a_init)) error stop 56
if (any (a3 /= a_init)) error stop 56
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_rank_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
if (any (a /= a_init)) error stop 58
if (any (a2 /= a_init)) error stop 58
if (any (a3 /= a_init)) error stop 58
! -- C: assumed rank contiguous
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_rank_cont_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_rank_cont_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_rank_cont_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
if (any (a /= a_init)) error stop 56
if (any (a2 /= a_init)) error stop 56
if (any (a3 /= a_init)) error stop 56
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_rank_cont_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
if (any (a /= a_init)) error stop 58
if (any (a2 /= a_init)) error stop 58
if (any (a3 /= a_init)) error stop 58
! -- C: assumed shape
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_shape_c (a(::2), a2(::2), a3(::2), len(a), num=1)
if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_shape_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_shape_in_c (a(::2), a2(::2), a3(::2), len(a), num=1)
if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
if (any (a /= a_init)) error stop 56
if (any (a2 /= a_init)) error stop 56
if (any (a3 /= a_init)) error stop 56
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_shape_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
if (any (a /= a_init)) error stop 58
if (any (a2 /= a_init)) error stop 58
if (any (a3 /= a_init)) error stop 58
! -- C: assumed shape contiguous
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_shape_cont_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_shape_cont_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_shape_cont_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
if (any (a /= a_init)) error stop 56
if (any (a2 /= a_init)) error stop 56
if (any (a3 /= a_init)) error stop 56
a = a_init; a2 = a_init; a3 = a_init
loc3 = char_assumed_shape_cont_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
if (any (a /= a_init)) error stop 58
if (any (a2 /= a_init)) error stop 58
if (any (a3 /= a_init)) error stop 58
end
! { dg-output "At line 928 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_f'(\n|\r\n|\r)" }"
! { dg-output "At line 928 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_f'(\n|\r\n|\r)" }"
! { dg-output "At line 928 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_f'(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output "At line 946 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_in_f'(\n|\r\n|\r)" }"
! { dg-output "At line 946 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_in_f'(\n|\r\n|\r)" }"
! { dg-output "At line 946 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_in_f'(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output "At line 965 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_f'(\n|\r\n|\r)" }"
! { dg-output "At line 965 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_f'(\n|\r\n|\r)" }"
! { dg-output "At line 965 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_f'(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output "At line 983 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_in_f'(\n|\r\n|\r)" }"
! { dg-output "At line 983 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_in_f'(\n|\r\n|\r)" }"
! { dg-output "At line 983 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_in_f'(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output "At line 1039 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_f'(\n|\r\n|\r)" }"
! { dg-output "At line 1039 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_f'(\n|\r\n|\r)" }"
! { dg-output "At line 1039 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_f'(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output "At line 1057 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_in_f'(\n|\r\n|\r)" }"
! { dg-output "At line 1057 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_in_f'(\n|\r\n|\r)" }"
! { dg-output "At line 1057 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_in_f'(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output "At line 1113 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_f'(\n|\r\n|\r)" }"
! { dg-output "At line 1113 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_f'(\n|\r\n|\r)" }"
! { dg-output "At line 1113 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_f'(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output "At line 1131 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_in_f'(\n|\r\n|\r)" }"
! { dg-output "At line 1131 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_in_f'(\n|\r\n|\r)" }"
! { dg-output "At line 1131 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_in_f'(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output "At line 1153 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_c'(\n|\r\n|\r)" }"
! { dg-output "At line 1153 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_c'(\n|\r\n|\r)" }"
! { dg-output "At line 1153 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_c'(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output "At line 1171 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_in_c'(\n|\r\n|\r)" }"
! { dg-output "At line 1171 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_in_c'(\n|\r\n|\r)" }"
! { dg-output "At line 1171 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_in_c'(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output "At line 1190 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_c'(\n|\r\n|\r)" }"
! { dg-output "At line 1190 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_c'(\n|\r\n|\r)" }"
! { dg-output "At line 1190 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_c'(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output "At line 1208 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_in_c'(\n|\r\n|\r)" }"
! { dg-output "At line 1208 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_in_c'(\n|\r\n|\r)" }"
! { dg-output "At line 1208 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_in_c'(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output "At line 1264 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_c'(\n|\r\n|\r)" }"
! { dg-output "At line 1264 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_c'(\n|\r\n|\r)" }"
! { dg-output "At line 1264 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_c'(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output "At line 1282 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_in_c'(\n|\r\n|\r)" }"
! { dg-output "At line 1282 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_in_c'(\n|\r\n|\r)" }"
! { dg-output "At line 1282 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_in_c'(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output "At line 1338 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_c'(\n|\r\n|\r)" }"
! { dg-output "At line 1338 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_c'(\n|\r\n|\r)" }"
! { dg-output "At line 1338 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_c'(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"
! { dg-output "At line 1356 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_in_c'(\n|\r\n|\r)" }"
! { dg-output "At line 1356 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_in_c'(\n|\r\n|\r)" }"
! { dg-output "At line 1356 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_in_c'(\n|\r\n|\r)" }"
! { dg-output " abcghinop(\n|\r\n|\r)" }"
! { dg-output " defghijlm(\n|\r\n|\r)" }"