@@ -1301,10 +1301,13 @@ 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)
+get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype,
+ gfc_ss **fcnss)
{
+ 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;
@@ -1313,11 +1316,13 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype)
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
temporary; ie. the rhs of the assignment. */
- rhs_ss = ss->loop->ss->loop_chain;
+ rhs_ss = loop_ss->loop_chain;
if (rhs_ss != gfc_ss_terminator
&& rhs_ss->info
@@ -1335,19 +1340,49 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype)
rhs_function = true;
}
+ /* Usually, ss points to the function. When the function call is an actual
+ argument, it is instead rhs_ss. */
+ *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 (rhs_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! */
+ expression! Otherwise, the class container from arg1 can be used
+ to set the vptr and len fields of the result class container. */
lhs_ss = rhs_ss->loop_chain;
- if (lhs_ss != gfc_ss_terminator
- && lhs_ss->info
- && lhs_ss->info->expr
+ if (lhs_ss && 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 (rhs_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 (rhs_class_expr);
+ if (unlimited_arg1)
+ gfc_add_modify (pre, tmp, gfc_class_len_get (cntnr));
+ }
+ tmp = NULL_TREE;
+ }
else
tmp = NULL_TREE;
@@ -1369,11 +1404,9 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype)
gfc_class_vptr_get (rhs_class_expr)));
if (unlimited_lhs)
{
+ gcc_assert (unlimited_rhs);
tmp = gfc_class_len_get (lhs_class_expr);
- if (unlimited_rhs)
- tmp2 = gfc_class_len_get (rhs_class_expr);
- else
- tmp2 = build_int_cst (TREE_TYPE (tmp), 0);
+ tmp2 = gfc_class_len_get (rhs_class_expr);
gfc_add_modify (pre, tmp, tmp2);
}
@@ -1383,7 +1416,7 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype)
gfc_conv_descriptor_offset_set (pre, tmp, gfc_index_zero_node);
}
}
- else
+ else if (rhs_ss->info->data.array.descriptor)
{
/* lhs is class and rhs is intrinsic or derived type. */
*eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor);
@@ -1452,6 +1485,7 @@ 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;
@@ -1471,7 +1505,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);
+ class_expr = get_class_info_from_ss (pre, ss, &eltype, &fcn_ss);
/* If the dynamic type is not available, use the declared type. */
if (eltype && GFC_CLASS_TYPE_P (eltype))
@@ -1571,14 +1605,46 @@ 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)
+ if (class_expr != NULL_TREE
+ || (fcn_ss && fcn_ss->info && fcn_ss->info->class_container))
{
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);
- /* Create a class temporary. */
- tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp");
- gfc_add_modify (pre, tmp, class_expr);
+ /* 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));
+ }
/* Assign the new descriptor to the _data field. This allows the
vptr _copy to be used for scalarized assignment since the class
@@ -1588,11 +1654,25 @@ 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);
- /* 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);
+ 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);
+ /* 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;
}
@@ -5983,6 +6063,14 @@ 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);
@@ -1176,6 +1176,21 @@ 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 canbe 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;
@@ -6258,7 +6273,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;
@@ -6266,6 +6281,8 @@ 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);
@@ -7375,6 +7392,19 @@ 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
@@ -7961,6 +7991,7 @@ 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. */
@@ -8241,8 +8272,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
argument is actually given. */
arg = expr->value.function.actual;
if (result && arg && expr->rank
- && expr->value.function.isym
- && expr->value.function.isym->transformational
+ && isym && isym->transformational
&& arg->expr
&& arg->expr->ts.type == BT_DERIVED
&& arg->expr->ts.u.derived->attr.alloc_comp)
@@ -11187,7 +11217,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)
+fcncall_realloc_result (gfc_se *se, int rank, tree dtype)
{
tree desc;
tree res_desc;
@@ -11206,7 +11236,10 @@ fcncall_realloc_result (gfc_se *se, int rank)
/* Unallocated, the descriptor does not have a dtype. */
tmp = gfc_conv_descriptor_dtype (desc);
- gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (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)));
res_desc = gfc_evaluate_now (desc, &se->pre);
gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node);
@@ -11423,7 +11456,19 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
ss->is_alloc_lhs = 1;
}
else
- fcncall_realloc_result (&se, expr1->rank);
+ {
+ 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);
+ }
}
gfc_conv_function_expr (&se, expr2);
new file mode 100644
@@ -0,0 +1,204 @@
+! { 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(*), allocatable :: 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
new file mode 100644
@@ -0,0 +1,103 @@
+! { 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