https://gcc.gnu.org/g:f9f599a44e3156a5f5679adc048ec6ff2f44cc0e
commit r15-3123-gf9f599a44e3156a5f5679adc048ec6ff2f44cc0e
Author: Paul Thomas <pa...@gcc.gnu.org>
Date: Fri Aug 23 13:16:53 2024 +0100
Revert "Fortran: Fix class transformational intrinsic calls [PR102689]"
This reverts commit 4cb07a38233aadb4b389a6e5236c95f52241b6e0.
Diff:
---
gcc/fortran/trans-array.cc | 146 +++------------
gcc/fortran/trans-expr.cc | 57 +-----
.../gfortran.dg/class_transformational_1.f90 | 204 ---------------------
.../gfortran.dg/class_transformational_2.f90 | 103 -----------
4 files changed, 35 insertions(+), 475 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index ea5fff2e0c29..8c35926436d7 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -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);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 8801a15c3a8d..909cdeb4e59b 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -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);
diff --git a/gcc/testsuite/gfortran.dg/class_transformational_1.f90
b/gcc/testsuite/gfortran.dg/class_transformational_1.f90
deleted file mode 100644
index 375e011b9f56..000000000000
--- a/gcc/testsuite/gfortran.dg/class_transformational_1.f90
+++ /dev/null
@@ -1,204 +0,0 @@
-! { dg-do run }
-!
-! Test transformational intrinsics with class results - PR102689
-!
-! Contributed by Tobias Burnus <bur...@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
diff --git a/gcc/testsuite/gfortran.dg/class_transformational_2.f90
b/gcc/testsuite/gfortran.dg/class_transformational_2.f90
deleted file mode 100644
index 908758b75488..000000000000
--- a/gcc/testsuite/gfortran.dg/class_transformational_2.f90
+++ /dev/null
@@ -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 <pa...@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
