procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Revert "Fortran: Fix class transformational intrinsic calls [PR102689]"

Browse source 
This reverts commit 4cb07a3823.
This commit is contained in:
Paul Thomas 2024-08-23 13:16:53 +01:00
parent 07988874c3
commit f9f599a44e
4 changed files with 35 additions and 475 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

146
gcc/fortran/trans-array.cc
View file

@ -1301,28 +1301,23 @@ get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
is a class expression. */
static tree
get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype,
gfc_ss **fcnss)
get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype)
{
gfc_ss *loop_ss = ss->loop->ss;
gfc_ss *lhs_ss;
gfc_ss *rhs_ss;
gfc_ss *fcn_ss = NULL;
tree tmp;
tree tmp2;
tree vptr;
tree class_expr = NULL_TREE;
tree rhs_class_expr = NULL_TREE;
tree lhs_class_expr = NULL_TREE;
bool unlimited_rhs = false;
bool unlimited_lhs = false;
bool rhs_function = false;
bool unlimited_arg1 = false;
gfc_symbol *vtab;
tree cntnr = NULL_TREE;
/* The second element in the loop chain contains the source for the
class temporary created in gfc_trans_create_temp_array. */
rhs_ss = loop_ss->loop_chain;
temporary; ie. the rhs of the assignment. */
rhs_ss = ss->loop->ss->loop_chain;
if (rhs_ss != gfc_ss_terminator
&& rhs_ss->info
@ -1331,58 +1326,28 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype,
&& rhs_ss->info->data.array.descriptor)
{
if (rhs_ss->info->expr->expr_type != EXPR_VARIABLE)
class_expr
rhs_class_expr
= gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor);
else
class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr);
rhs_class_expr = gfc_get_class_from_gfc_expr (rhs_ss->info->expr);
unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr);
if (rhs_ss->info->expr->expr_type == EXPR_FUNCTION)
rhs_function = true;
}
/* Usually, ss points to the function. When the function call is an actual
argument, it is instead rhs_ss because the ss chain is shifted by one. */
*fcnss = fcn_ss = rhs_function ? rhs_ss : ss;
/* If this is a transformational function with a class result, the info
class_container field points to the class container of arg1. */
if (class_expr != NULL_TREE
&& fcn_ss->info && fcn_ss->info->expr
&& fcn_ss->info->expr->expr_type == EXPR_FUNCTION
&& fcn_ss->info->expr->value.function.isym
&& fcn_ss->info->expr->value.function.isym->transformational)
{
cntnr = ss->info->class_container;
unlimited_arg1
= UNLIMITED_POLY (fcn_ss->info->expr->value.function.actual->expr);
}
/* For an assignment the lhs is the next element in the loop chain.
If we have a class rhs, this had better be a class variable
expression! Otherwise, the class container from arg1 can be used
to set the vptr and len fields of the result class container. */
expression! */
lhs_ss = rhs_ss->loop_chain;
if (lhs_ss && lhs_ss != gfc_ss_terminator
&& lhs_ss->info && lhs_ss->info->expr
if (lhs_ss != gfc_ss_terminator
&& lhs_ss->info
&& lhs_ss->info->expr
&& lhs_ss->info->expr->expr_type ==EXPR_VARIABLE
&& lhs_ss->info->expr->ts.type == BT_CLASS)
{
tmp = lhs_ss->info->data.array.descriptor;
unlimited_lhs = UNLIMITED_POLY (rhs_ss->info->expr);
}
else if (cntnr != NULL_TREE)
{
tmp = gfc_class_vptr_get (class_expr);
gfc_add_modify (pre, tmp, fold_convert (TREE_TYPE (tmp),
gfc_class_vptr_get (cntnr)));
if (unlimited_rhs)
{
tmp = gfc_class_len_get (class_expr);
if (unlimited_arg1)
gfc_add_modify (pre, tmp, gfc_class_len_get (cntnr));
}
tmp = NULL_TREE;
}
else
tmp = NULL_TREE;
@ -1390,33 +1355,35 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype,
if (tmp != NULL_TREE && lhs_ss->loop_chain == gfc_ss_terminator)
lhs_class_expr = gfc_get_class_from_expr (tmp);
else
return class_expr;
return rhs_class_expr;
gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr)));
/* Set the lhs vptr and, if necessary, the _len field. */
if (class_expr)
if (rhs_class_expr)
{
/* Both lhs and rhs are class expressions. */
tmp = gfc_class_vptr_get (lhs_class_expr);
gfc_add_modify (pre, tmp,
fold_convert (TREE_TYPE (tmp),
gfc_class_vptr_get (class_expr)));
gfc_class_vptr_get (rhs_class_expr)));
if (unlimited_lhs)
{
gcc_assert (unlimited_rhs);
tmp = gfc_class_len_get (lhs_class_expr);
tmp2 = gfc_class_len_get (class_expr);
if (unlimited_rhs)
tmp2 = gfc_class_len_get (rhs_class_expr);
else
tmp2 = build_int_cst (TREE_TYPE (tmp), 0);
gfc_add_modify (pre, tmp, tmp2);
}
if (rhs_function)
{
tmp = gfc_class_data_get (class_expr);
tmp = gfc_class_data_get (rhs_class_expr);
gfc_conv_descriptor_offset_set (pre, tmp, gfc_index_zero_node);
}
}
else if (rhs_ss->info->data.array.descriptor)
else
{
/* lhs is class and rhs is intrinsic or derived type. */
*eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor);
@ -1444,7 +1411,7 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype,
}
}
return class_expr;
return rhs_class_expr;
}
@ -1485,7 +1452,6 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
tree or_expr;
tree elemsize;
tree class_expr = NULL_TREE;
gfc_ss *fcn_ss = NULL;
int n, dim, tmp_dim;
int total_dim = 0;
@ -1505,7 +1471,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
The descriptor can be obtained from the ss->info and then converted
to the class object. */
if (class_expr == NULL_TREE && GFC_CLASS_TYPE_P (eltype))
class_expr = get_class_info_from_ss (pre, ss, &eltype, &fcn_ss);
class_expr = get_class_info_from_ss (pre, ss, &eltype);
/* If the dynamic type is not available, use the declared type. */
if (eltype && GFC_CLASS_TYPE_P (eltype))
@ -1605,46 +1571,14 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
gfc_add_expr_to_block (pre, build1 (DECL_EXPR,
arraytype, TYPE_NAME (arraytype)));
if (class_expr != NULL_TREE
|| (fcn_ss && fcn_ss->info && fcn_ss->info->class_container))
if (class_expr != NULL_TREE)
{
tree class_data;
tree dtype;
gfc_expr *expr1 = fcn_ss ? fcn_ss->info->expr : NULL;
/* Create a class temporary for the result using the lhs class object. */
if (class_expr != NULL_TREE)
{
tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp");
gfc_add_modify (pre, tmp, class_expr);
}
else
{
tree vptr;
class_expr = fcn_ss->info->class_container;
gcc_assert (expr1);
/* Build a new class container using the arg1 class object. The class
typespec must be rebuilt because the rank might have changed. */
gfc_typespec ts = CLASS_DATA (expr1)->ts;
symbol_attribute attr = CLASS_DATA (expr1)->attr;
gfc_change_class (&ts, &attr, NULL, expr1->rank, 0);
tmp = gfc_create_var (gfc_typenode_for_spec (&ts), "ctmp");
fcn_ss->info->class_container = tmp;
/* Set the vptr and obtain the element size. */
vptr = gfc_class_vptr_get (tmp);
gfc_add_modify (pre, vptr,
fold_convert (TREE_TYPE (vptr),
gfc_class_vptr_get (class_expr)));
elemsize = gfc_class_vtab_size_get (class_expr);
elemsize = gfc_evaluate_now (elemsize, pre);
/* Set the _len field, if necessary. */
if (UNLIMITED_POLY (expr1))
gfc_add_modify (pre, gfc_class_len_get (tmp),
gfc_class_len_get (class_expr));
}
/* Create a class temporary. */
tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp");
gfc_add_modify (pre, tmp, class_expr);
/* Assign the new descriptor to the _data field. This allows the
vptr _copy to be used for scalarized assignment since the class
@ -1654,25 +1588,11 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
TREE_TYPE (desc), desc);
gfc_add_modify (pre, class_data, tmp);
if (expr1 && expr1->expr_type == EXPR_FUNCTION
&& expr1->value.function.isym
&& (expr1->value.function.isym->id == GFC_ISYM_RESHAPE
|| expr1->value.function.isym->id == GFC_ISYM_UNPACK))
{
/* Take the dtype from the class expression. */
dtype = gfc_conv_descriptor_dtype (gfc_class_data_get (class_expr));
tmp = gfc_conv_descriptor_dtype (class_data);
gfc_add_modify (pre, tmp, dtype);
/* Take the dtype from the class expression. */
dtype = gfc_conv_descriptor_dtype (gfc_class_data_get (class_expr));
tmp = gfc_conv_descriptor_dtype (class_data);
gfc_add_modify (pre, tmp, dtype);
/* Transformational functions reshape and reduce can change the rank. */
if (fcn_ss && fcn_ss->info && fcn_ss->info->class_container)
{
tmp = gfc_conv_descriptor_rank (class_data);
gfc_add_modify (pre, tmp,
build_int_cst (TREE_TYPE (tmp), ss->loop->dimen));
fcn_ss->info->class_container = NULL_TREE;
}
}
/* Point desc to the class _data field. */
desc = class_data;
}
@ -6070,14 +5990,6 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
tmp = gfc_conv_descriptor_dtype (descriptor);
gfc_add_modify (pblock, tmp, gfc_conv_descriptor_dtype (expr3_desc));
}
else if (expr->ts.type == BT_CLASS
&& expr3 && expr3->ts.type != BT_CLASS
&& expr3_elem_size != NULL_TREE && expr3_desc == NULL_TREE)
{
tmp = gfc_conv_descriptor_elem_len (descriptor);
gfc_add_modify (pblock, tmp,
fold_convert (TREE_TYPE (tmp), expr3_elem_size));
}
else
{
tmp = gfc_conv_descriptor_dtype (descriptor);

57
gcc/fortran/trans-expr.cc
View file

@ -1231,21 +1231,6 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
stmtblock_t block;
bool full_array = false;
/* Class transformational function results are the data field of a class
temporary and so the class expression can be obtained directly. */
if (e->expr_type == EXPR_FUNCTION
&& e->value.function.isym
&& e->value.function.isym->transformational
&& TREE_CODE (parmse->expr) == COMPONENT_REF
&& !GFC_CLASS_TYPE_P (TREE_TYPE (parmse->expr)))
{
parmse->expr = TREE_OPERAND (parmse->expr, 0);
if (!VAR_P (parmse->expr))
parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre);
parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
return;
}
gfc_init_block (&block);
class_ref = NULL;
@ -6354,7 +6339,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_component *comp = NULL;
int arglen;
unsigned int argc;
tree arg1_cntnr = NULL_TREE;
arglist = NULL;
retargs = NULL;
stringargs = NULL;
@ -6362,8 +6347,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
var = NULL_TREE;
len = NULL_TREE;
gfc_clear_ts (&ts);
gfc_intrinsic_sym *isym = expr && expr->rank ?
expr->value.function.isym : NULL;
comp = gfc_get_proc_ptr_comp (expr);
@ -7458,19 +7441,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
e->representation.length);
}
/* Make the class container for the first argument available with class
valued transformational functions. */
if (argc == 0 && e && e->ts.type == BT_CLASS
&& isym && isym->transformational
&& se->ss && se->ss->info)
{
arg1_cntnr = parmse.expr;
if (POINTER_TYPE_P (TREE_TYPE (arg1_cntnr)))
arg1_cntnr = build_fold_indirect_ref_loc (input_location, arg1_cntnr);
arg1_cntnr = gfc_get_class_from_expr (arg1_cntnr);
se->ss->info->class_container = arg1_cntnr;
}
if (fsym && e)
{
/* Obtain the character length of an assumed character length
@ -8072,7 +8042,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* Set the type of the array. */
tmp = gfc_typenode_for_spec (&ts);
tmp = arg1_cntnr ? TREE_TYPE (arg1_cntnr) : tmp;
gcc_assert (se->ss->dimen == se->loop->dimen);
/* Evaluate the bounds of the result, if known. */
@ -8353,7 +8322,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
argument is actually given. */
arg = expr->value.function.actual;
if (result && arg && expr->rank
&& isym && isym->transformational
&& expr->value.function.isym
&& expr->value.function.isym->transformational
&& arg->expr
&& arg->expr->ts.type == BT_DERIVED
&& arg->expr->ts.u.derived->attr.alloc_comp)
@ -11329,7 +11299,7 @@ realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss,
result to the original descriptor. */
static void
fcncall_realloc_result (gfc_se *se, int rank, tree dtype)
fcncall_realloc_result (gfc_se *se, int rank)
{
tree desc;
tree res_desc;
@ -11348,10 +11318,7 @@ fcncall_realloc_result (gfc_se *se, int rank, tree dtype)
/* Unallocated, the descriptor does not have a dtype. */
tmp = gfc_conv_descriptor_dtype (desc);
if (dtype != NULL_TREE)
gfc_add_modify (&se->pre, tmp, dtype);
else
gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
res_desc = gfc_evaluate_now (desc, &se->pre);
gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
@ -11568,19 +11535,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
ss->is_alloc_lhs = 1;
}
else
{
tree dtype = NULL_TREE;
tree type = gfc_typenode_for_spec (&expr2->ts);
if (expr1->ts.type == BT_CLASS)
{
tmp = gfc_class_vptr_get (sym->backend_decl);
tree tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
gfc_add_modify (&se.pre, tmp, tmp2);
dtype = gfc_get_dtype_rank_type (expr1->rank,type);
}
fcncall_realloc_result (&se, expr1->rank, dtype);
}
fcncall_realloc_result (&se, expr1->rank);
}
gfc_conv_function_expr (&se, expr2);

204
gcc/testsuite/gfortran.dg/class_transformational_1.f90
View file

@ -1,204 +0,0 @@
! { dg-do run }
!
! Test transformational intrinsics with class results - PR102689
!
! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
!
module tests
type t
integer :: i
end type t
type, extends(t) :: s
integer :: j
end type
contains
subroutine class_bar(x)
class(*), intent(in) :: x(..)
integer :: checksum
if (product (shape (x)) .ne. 10) stop 1
select rank (x)
rank (1)
select type (x)
type is (s)
if (sum(x%i) .ne. 55) stop 2
if ((sum(x%j) .ne. 550) .and. (sum(x%j) .ne. 110)) stop 3
type is (character(*))
checksum = sum(ichar(x(:)(1:1)) + ichar(x(:)(2:2)))
if ((checksum .ne. 1490) .and. (checksum .ne. 2130)) stop 4
class default
stop
end select
rank (2)
select type (x)
type is (s)
if (sum(x%i) .ne. 55) stop 5
if (sum(x%j) .ne. 550) stop 6
type is (character(*));
checksum = sum(ichar(x(:,:)(1:1)) + ichar(x(:,:)(2:2)))
if ((checksum .ne. 1490) .and. (checksum .ne. 2130)) stop 7
class default
stop 8
end select
rank (3)
select type (x)
type is (s)
if (sum(x%i) .ne. 55) stop 9
if ((sum(x%j) .ne. 550) .and. (sum(x%j) .ne. 110)) stop 10
type is (character(*))
checksum = sum(ichar(x(:,:,:)(1:1)) + ichar(x(:,:,:)(2:2)))
if ((checksum .ne. 1490) .and. (checksum .ne. 2130)) stop 11
class default
stop 12
end select
end select
end
end module tests
Module class_tests
use tests
implicit none
private
public :: test_class
integer :: j
integer :: src(10)
type (s), allocatable :: src3 (:,:,:)
class(t), allocatable :: B(:,:,:), D(:)
! gfortran gave type(t) for D for all these test cases.
contains
subroutine test_class
src3 = reshape ([(s(j,j*10), j=1,10)], [1,10,1])
call test1 ! Now D OK for gfc15. B OK back to gfc10
call foo
call class_rebar(reshape(B, [10])) ! This is the original failure - run time segfault
deallocate (B, D)
allocate(B(2,1,5), source = s(1,11)) ! B was OK but descriptor elem_len = 4 so....
src = [(j, j=1,10)]
call test2 ! D%j was type(t) and filled with B[1:5]
call foo
deallocate (B,D)
call test3 ! B is set to type(t) and filled with [s(1,11)..s(5,50)]
call foo
deallocate (B,D)
B = src3 ! Now D was like B in test3. B OK back to gfc10
call foo
deallocate (B, D)
end
subroutine class_rebar (arg)
class(t) :: arg(:)
call class_bar (arg)
end
subroutine test1
allocate(B, source = src3)
end
subroutine test2
B%i = RESHAPE(src, shape(B))
end
subroutine test3
B = reshape ([(s(j,j*10), j=1,10)], shape(B))
end
subroutine foo
D = reshape(B, [10])
call class_bar(B)
call class_bar(D)
end
end module class_tests
module unlimited_tests
use tests
implicit none
private
public :: test_unlimited
integer :: j
integer :: src(10)
character(len = 2, kind = 1) :: chr(10)
character(len = 2, kind = 1) :: chr3(5, 2, 1)
type (s), allocatable :: src3 (:,:,:)
class(*), allocatable :: B(:,:,:), D(:)
contains
subroutine test_unlimited
call test1
call foo
call unlimited_rebar(reshape(B, [10])) ! Unlimited version of the original failure
deallocate (B, D)
call test3
call foo
deallocate (B,D)
B = src3
call foo
deallocate (B, D)
B = reshape ([(char(64 + 2*j - 1)//char(64 + 2*j), j = 1,10)], [5, 1, 2])
call foo
deallocate (B, D)
chr = [(char(96 + 2*j - 1)//char(96 + 2*j), j = 1,10)]
B = reshape (chr, [5, 1, 2])
call foo
call unlimited_rebar(reshape(B, [10])) ! Unlimited/ character version of the original failure
deallocate (B, D)
chr3 = reshape (chr, shape(chr3))
B = chr3
call foo
deallocate (B, D)
end
subroutine unlimited_rebar (arg)
class(*) :: arg(:)
call class_bar (arg)
end
subroutine test1
src3 = reshape ([(s(j,j*10), j=1,10)], [2,1,5])
allocate(B, source = src3)
end
subroutine test3
B = reshape ([(s(j,j*10), j=1,10)], shape(B))
end
subroutine foo
D = reshape(B, [10])
call class_bar(B)
call class_bar(D)
end
end module unlimited_tests
call t1
call t2
contains
subroutine t1
use class_tests
call test_class
end
subroutine t2
use unlimited_tests
call test_unlimited
end
end

103
gcc/testsuite/gfortran.dg/class_transformational_2.f90
View file

@ -1,103 +0,0 @@
! { dg-do run }
!
! Test transformational intrinsics other than reshape with class results.
! This emerged from PR102689, for which class_transformational_1.f90 tests
! class-valued reshape.
!
! Contributed by Paul Thomas <pault@gcc.gnu.org>
!
type t
integer :: i
end type t
type, extends(t) :: s
integer :: j
end type
class(t), allocatable :: scalar, a(:), aa(:), b(:,:), c(:,:,:), field(:,:,:)
integer, allocatable :: ishape(:), ii(:), ij(:)
logical :: la(2), lb(2,2), lc (4,2,2)
integer :: j, stop_flag
call check_spread
call check_pack
call check_unpack
call check_eoshift
call check_eoshift_dep
contains
subroutine check_result_a (shift)
type (s), allocatable :: ss(:)
integer :: shift
select type (aa)
type is (s)
ss = eoshift (aa, shift = shift, boundary = aa(1), dim = 1)
ishape = shape (aa);
ii = ss%i
ij = ss%j
end select
if (any (ishape .ne. shape (a))) stop stop_flag + 1
select type (a)
type is (s)
if (any (a%i .ne. ii)) stop stop_flag + 2
if (any (a%j .ne. ij)) stop stop_flag + 3
end select
end
subroutine check_result
if (any (shape (c) .ne. ishape)) stop stop_flag + 1
select type (a)
type is (s)
if (any (a%i .ne. ii)) stop stop_flag + 2
if (any (a%j .ne. ij)) stop stop_flag + 3
end select
end
subroutine check_spread
stop_flag = 10
a = [(s(j,10*j), j = 1,2)]
b = spread (a, dim = 2, ncopies = 2)
c = spread (b, dim = 1, ncopies = 4)
a = reshape (c, [size (c)])
ishape = [4,2,2]
ii = [1,1,1,1,2,2,2,2,1,1,1,1,2,2,2,2]
ij = 10*[1,1,1,1,2,2,2,2,1,1,1,1,2,2,2,2]
call check_result
end
subroutine check_pack
stop_flag = 20
la = [.false.,.true.]
lb = spread (la, dim = 2, ncopies = 2)
lc = spread (lb, dim = 1, ncopies = 4)
a = pack (c, mask = lc)
ishape = shape (lc)
ii = [2,2,2,2,2,2,2,2]
ij = 10*[2,2,2,2,2,2,2,2]
call check_result
end
subroutine check_unpack
stop_flag = 30
a = [(s(j,10*j), j = 1,16)]
field = reshape ([(s(100*j,1000*j), j = 1,16)], shape(lc))
c = unpack (a, mask = lc, field = field)
a = reshape (c, [product (shape (lc))])
ishape = shape (lc)
ii = [100,200,300,400,1,2,3,4,900,1000,1100,1200,5,6,7,8]
ij = [1000,2000,3000,4000,10,20,30,40,9000,10000, 11000,12000,50,60,70,80]
call check_result
end
subroutine check_eoshift
type (s), allocatable :: ss(:)
stop_flag = 40
aa = a
a = eoshift (aa, shift = 3, boundary = aa(1), dim = 1)
call check_result_a (3)
end
subroutine check_eoshift_dep
stop_flag = 50
aa = a
a = eoshift (a, shift = -3, boundary = a(1), dim = 1)
call check_result_a (-3)
end
end