This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.
| Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
|---|---|---|
| Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |
| Other format: | [Raw text] | |
Dear all, during his initial tests Dominique pointed out, that my patch did not fix all issues in the comments of pr60322. This new version of the patch fixes this issue now. The trick is to use a temporary array in the variable association of select type statements. The old code referenced the incoming array directly. This array may have an arbitrary base (i.e. lbound != 1) making indexing very difficult. Creating a temporary array descriptor for the associated variable allows for having the array base set to one (i.e., lbound == 1) making indexing fairly simple and adhere to the Fortran rules. The patch boostraps and regtests cleanly on x86_64-linux-gnu/F20. Note, you need to apply part 1 of this patch first. Part 1 can be found at: https://gcc.gnu.org/ml/fortran/2015-02/msg00105.html Regards, Andre On Thu, 26 Feb 2015 18:17:21 +0100 Andre Vehreschild <vehre@gmx.de> wrote: > Hi all, > > here is the second part of the patch for pr60322. This patch also addresses > the issue reported in pr64692, ... (more to come). > > The patch fixes the incorrect bounds of polymorphic arrays used to call > functions and subroutines by using the same mechanism as regular arrays. In > fact most of the code for treating regular arrays is reused by simply > inserting the class array's symbol_attributes and gfc_array_specs into the > same routines, i.e., doing the switching whether a symbol is a class array or > a regular array and assigning the CLASS_DATA(sym).attr or sym.attr to the > symbol_attribute temporary variable introduced by the first part (same for > gfc_array_spec). The temporary array descriptor is then stored in the tree > and extracted were it is needed. > > This patch furthermore addresses an issue with elemental functions, where the > elemental function was not applied to class array members. By introducing the > temporary array this merely fixed itself. > > During fixing elemental function application, an issue about using the > polymorphic initializer popped up. The existing code would declare a variable > of the base type (not a reference or pointer to it), assign the _vptr's > _def_init to it and use the _vptr's _copy to copy the initializer into the > object to initialize. This had to be patched to use a pointer for the variable > and the correct addressing to be able to make use of the polymorphic init. > > Furthermore is the array offset in certain cases set to be -1. This helped to > get the addressing correct for subarrays of (unlimited polymorphic) objects, > where the array offset is used in a "select type" or other kind of association > and the with the offset set incorrectly wrong elements from the array were > selected. > > I had to fix two testcases, too: > - finalize_15: We agreed (including checking with other compilers) that the > value of an intent(out) variable should be that of its initializer and not > that of its finalizer. > - finalize_10: By using the temporary arrays the scan-tree-count expressions > had to be adapted, too. > > Thank you's go to: Tobias, Dominique and Paul for their support during > figuring what it going wrong and thorough testing and to Antony for reporting > the issue. > > Bootstraps and regtests ok on x86_64-linux-gnu/F20. > > Regards, > Andre -- Andre Vehreschild * Email: vehre ad gmx dot de
Attachment:
pr60322_2.clog
Description: Binary data
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index d28cf77..7f3a59d 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4060,7 +4060,7 @@ gfc_lval_expr_from_sym (gfc_symbol *sym)
lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
/* It will always be a full array. */
- as = sym->as;
+ as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
lval->rank = as ? as->rank : 0;
if (lval->rank)
gfc_add_full_array_ref (lval, as);
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index ff0054e..f55c691 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3198,6 +3198,11 @@ bool gfc_is_finalizable (gfc_symbol *, gfc_expr **);
&& CLASS_DATA (sym) \
&& CLASS_DATA (sym)->ts.u.derived \
&& CLASS_DATA (sym)->ts.u.derived->attr.unlimited_polymorphic)
+#define IS_CLASS_ARRAY(sym) \
+ (sym->ts.type == BT_CLASS \
+ && CLASS_DATA (sym) \
+ && CLASS_DATA (sym)->attr.dimension \
+ && !CLASS_DATA (sym)->attr.class_pointer)
/* frontend-passes.c */
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 0d4d7b2..22fc7c7 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -2495,11 +2495,14 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript,
case GFC_SS_REFERENCE:
/* Scalar argument to elemental procedure. */
gfc_init_se (&se, NULL);
- if (ss_info->can_be_null_ref)
+ if (ss_info->can_be_null_ref || (expr->symtree
+ && (expr->symtree->n.sym->ts.type == BT_DERIVED
+ || expr->symtree->n.sym->ts.type == BT_CLASS)))
{
/* If the actual argument can be absent (in other words, it can
be a NULL reference), don't try to evaluate it; pass instead
- the reference directly. */
+ the reference directly. The reference is also needed when
+ expr is of type class or derived. */
gfc_conv_expr_reference (&se, expr);
}
else
@@ -3046,7 +3049,14 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
return false;
}
else if (class_ref == NULL)
- decl = expr->symtree->n.sym->backend_decl;
+ {
+ decl = expr->symtree->n.sym->backend_decl;
+ /* For class arrays the tree containing the class is stored in
+ GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
+ For all others it's sym's backend_decl directly. */
+ if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
+ decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
+ }
else
{
/* Remove everything after the last class reference, convert the
@@ -3159,26 +3169,41 @@ build_array_ref (tree desc, tree offset, tree decl)
{
tree tmp;
tree type;
+ tree cdecl;
+ bool classarray = false;
+
+ /* For class arrays the class declaration is stored in the saved
+ descriptor. */
+ if (INDIRECT_REF_P (desc)
+ && DECL_LANG_SPECIFIC (TREE_OPERAND (desc, 0))
+ && GFC_DECL_SAVED_DESCRIPTOR (TREE_OPERAND (desc, 0)))
+ cdecl = gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (
+ TREE_OPERAND (desc, 0)));
+ else
+ cdecl = desc;
/* Class container types do not always have the GFC_CLASS_TYPE_P
but the canonical type does. */
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
- && TREE_CODE (desc) == COMPONENT_REF)
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (cdecl))
+ && TREE_CODE (cdecl) == COMPONENT_REF)
{
- type = TREE_TYPE (TREE_OPERAND (desc, 0));
+ type = TREE_TYPE (TREE_OPERAND (cdecl, 0));
if (TYPE_CANONICAL (type)
&& GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
- type = TYPE_CANONICAL (type);
+ {
+ type = TREE_TYPE (desc);
+ classarray = true;
+ }
}
else
type = NULL;
/* Class array references need special treatment because the assigned
type size needs to be used to point to the element. */
- if (type && GFC_CLASS_TYPE_P (type))
+ if (classarray)
{
- type = gfc_get_element_type (TREE_TYPE (desc));
- tmp = TREE_OPERAND (desc, 0);
+ type = gfc_get_element_type (type);
+ tmp = TREE_OPERAND (cdecl, 0);
tmp = gfc_get_class_array_ref (offset, tmp);
tmp = fold_convert (build_pointer_type (type), tmp);
tmp = build_fold_indirect_ref_loc (input_location, tmp);
@@ -5568,7 +5593,7 @@ gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
gfc_se se;
gfc_array_spec *as;
- as = sym->as;
+ as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
for (dim = as->rank; dim < as->rank + as->corank; dim++)
{
@@ -5611,7 +5636,7 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
int dim;
- as = sym->as;
+ as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
size = gfc_index_one_node;
offset = gfc_index_zero_node;
@@ -5899,12 +5924,14 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
int no_repack;
bool optional_arg;
gfc_array_spec *as;
+ bool is_classarray = IS_CLASS_ARRAY (sym);
/* Do nothing for pointer and allocatable arrays. */
- if (sym->attr.pointer || sym->attr.allocatable)
+ if (sym->attr.pointer || sym->attr.allocatable
+ || (is_classarray && CLASS_DATA (sym)->attr.allocatable))
return;
- if (sym->attr.dummy && gfc_is_nodesc_array (sym))
+ if (!is_classarray && sym->attr.dummy && gfc_is_nodesc_array (sym))
{
gfc_trans_g77_array (sym, block);
return;
@@ -5917,8 +5944,13 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
type = TREE_TYPE (tmpdesc);
gcc_assert (GFC_ARRAY_TYPE_P (type));
dumdesc = GFC_DECL_SAVED_DESCRIPTOR (tmpdesc);
- dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
- as = sym->as;
+ if (is_classarray)
+ /* For a class array the dummy array descriptor is in the _class
+ component. */
+ dumdesc = gfc_class_data_get (dumdesc);
+ else
+ dumdesc = build_fold_indirect_ref_loc (input_location, dumdesc);
+ as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
gfc_start_block (&init);
if (sym->ts.type == BT_CHARACTER
@@ -6789,6 +6821,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
tree from;
tree to;
tree base;
+ bool onebased = false;
ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
@@ -6930,6 +6963,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
gfc_array_index_type, to, tmp);
from = gfc_index_one_node;
}
+ onebased = integer_onep (from);
gfc_conv_descriptor_lbound_set (&loop.pre, parm,
gfc_rank_cst[dim], from);
@@ -6986,13 +7020,27 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
gfc_get_dataptr_offset (&loop.pre, parm, desc, offset,
subref_array_target, expr);
- if (((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
- && !se->data_not_needed)
- || (se->use_offset && base != NULL_TREE))
+ /* Force the offset to be -1, when the lower bound of the highest
+ dimension is one and the symbol is present and is not a
+ pointer/allocatable or associated. */
+ if (onebased && se->use_offset
+ && expr->symtree
+ && !expr->symtree->n.sym->attr.allocatable
+ && !expr->symtree->n.sym->attr.pointer
+ && !expr->symtree->n.sym->attr.host_assoc
+ && !expr->symtree->n.sym->attr.use_assoc)
{
- /* Set the offset. */
- gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
+ /* Set the offset to -1. */
+ mpz_t minus_one;
+ mpz_init_set_si (minus_one, -1);
+ tmp = gfc_conv_mpz_to_tree (minus_one, gfc_index_integer_kind);
+ gfc_conv_descriptor_offset_set (&loop.pre, parm, tmp);
}
+ else if (((se->direct_byref || GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
+ && !se->data_not_needed)
+ || (se->use_offset && base != NULL_TREE))
+ /* Set the offset depending on base. */
+ gfc_conv_descriptor_offset_set (&loop.pre, parm, base);
else
{
/* Only the callee knows what the correct offset it, so just set
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index e571a17..64bdb11 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -813,10 +813,11 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
gfc_namespace* procns;
symbol_attribute *array_attr;
gfc_array_spec *as;
+ bool is_classarray = IS_CLASS_ARRAY (sym);
type = TREE_TYPE (decl);
- array_attr = &sym->attr;
- as = sym->as;
+ array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
+ as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
/* We just use the descriptor, if there is one. */
if (GFC_DESCRIPTOR_TYPE_P (type))
@@ -1022,10 +1023,11 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
gfc_packed packed;
int n;
bool known_size;
+ bool is_classarray = IS_CLASS_ARRAY (sym);
/* Use the array as and attr. */
- as = sym->as;
- array_attr = &sym->attr;
+ as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
+ array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
/* The pointer attribute is always set on a _data component, therefore check
the sym's attribute only. */
@@ -1038,24 +1040,27 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
if (sym->attr.result || sym->attr.dummy)
gfc_defer_symbol_init (sym);
- type = TREE_TYPE (dummy);
+ /* For a class array the array descriptor is in the _data component, while
+ for a regular array the TREE_TYPE of the dummy is a pointer to the
+ descriptor. */
+ type = TREE_TYPE (is_classarray ? gfc_class_data_get (dummy)
+ : TREE_TYPE (dummy));
+ /* type now is the array descriptor w/o any indirection. */
gcc_assert (TREE_CODE (dummy) == PARM_DECL
- && POINTER_TYPE_P (type));
+ && POINTER_TYPE_P (TREE_TYPE (dummy)));
/* Do we know the element size? */
known_size = sym->ts.type != BT_CHARACTER
|| INTEGER_CST_P (sym->ts.u.cl->backend_decl);
- if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
+ if (known_size && !GFC_DESCRIPTOR_TYPE_P (type))
{
/* For descriptorless arrays with known element size the actual
argument is sufficient. */
- gcc_assert (GFC_ARRAY_TYPE_P (type));
gfc_build_qualified_array (dummy, sym);
return dummy;
}
- type = TREE_TYPE (type);
if (GFC_DESCRIPTOR_TYPE_P (type))
{
/* Create a descriptorless array pointer. */
@@ -1089,7 +1094,10 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
packed = PACKED_PARTIAL;
}
- type = gfc_typenode_for_spec (&sym->ts);
+ /* For classarrays the element type is required, but
+ gfc_typenode_for_spec () returns the array descriptor. */
+ type = is_classarray ? gfc_get_element_type (type)
+ : gfc_typenode_for_spec (&sym->ts);
type = gfc_get_nodesc_array_type (type, as, packed,
!sym->attr.target);
}
@@ -1439,13 +1447,30 @@ gfc_get_symbol_decl (gfc_symbol * sym)
sym->backend_decl = decl;
}
+ /* Returning the descriptor for dummy class arrays is hazardous, because
+ some caller is expecting an expression to apply the component refs to.
+ Therefore the descriptor is only created and stored in
+ sym->backend_decl's GFC_DECL_SAVED_DESCRIPTOR. The caller then is
+ responsible to extract it from there, when the descriptor is
+ desired. */
+ if (IS_CLASS_ARRAY (sym)
+ && (!DECL_LANG_SPECIFIC (sym->backend_decl)
+ || !GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)))
+ {
+ decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
+ /* Prevent the dummy from being detected as unused if it is copied. */
+ if (sym->backend_decl != NULL && decl != sym->backend_decl)
+ DECL_ARTIFICIAL (sym->backend_decl) = 1;
+ sym->backend_decl = decl;
+ }
+
TREE_USED (sym->backend_decl) = 1;
if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
{
gfc_add_assign_aux_vars (sym);
}
- if (sym->attr.dimension
+ if ((sym->attr.dimension || IS_CLASS_ARRAY (sym))
&& DECL_LANG_SPECIFIC (sym->backend_decl)
&& GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)
&& DECL_CONTEXT (sym->backend_decl) != current_function_decl)
@@ -3982,14 +4007,16 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
= gfc_class_set_static_fields (sym->backend_decl, vptr, tmp);
TREE_CONSTANT (DECL_INITIAL (sym->backend_decl)) = 1;
}
- else if (sym->attr.dimension || sym->attr.codimension)
+ else if (sym->attr.dimension || sym->attr.codimension
+ || (IS_CLASS_ARRAY (sym) && !CLASS_DATA (sym)->attr.allocatable))
{
+ bool is_classarray = IS_CLASS_ARRAY (sym);
symbol_attribute *array_attr;
gfc_array_spec *as;
array_type tmp;
- array_attr = &sym->attr;
- as = sym->as;
+ array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
+ as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
/* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */
tmp = as->type;
if (tmp == AS_ASSUMED_SIZE && as->cp_was_assumed)
@@ -4119,6 +4146,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
}
else
{
+ se.descriptor_only = 1;
gfc_conv_expr (&se, e);
descriptor = se.expr;
se.expr = gfc_conv_descriptor_data_addr (se.expr);
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index db04b30..123011f 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -149,6 +149,11 @@ tree
gfc_class_vptr_get (tree decl)
{
tree vptr;
+ /* For class arrays decl may be a temporary array handle, the vptr then is
+ available through the saved descriptor. */
+ if (TREE_CODE (decl) == VAR_DECL && DECL_LANG_SPECIFIC (decl)
+ && GFC_DECL_SAVED_DESCRIPTOR (decl))
+ decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
if (POINTER_TYPE_P (TREE_TYPE (decl)))
decl = build_fold_indirect_ref_loc (input_location, decl);
vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
@@ -163,6 +168,11 @@ tree
gfc_class_len_get (tree decl)
{
tree len;
+ /* For class arrays decl may be a temporary array handle, the vptr then is
+ available through the saved descriptor. */
+ if (TREE_CODE (decl) == VAR_DECL && DECL_LANG_SPECIFIC (decl)
+ && GFC_DECL_SAVED_DESCRIPTOR (decl))
+ decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
if (POINTER_TYPE_P (TREE_TYPE (decl)))
decl = build_fold_indirect_ref_loc (input_location, decl);
len = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)),
@@ -798,7 +808,11 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
tmp = NULL_TREE;
if (class_ref == NULL
&& e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
- tmp = e->symtree->n.sym->backend_decl;
+ {
+ tmp = e->symtree->n.sym->backend_decl;
+ if (DECL_LANG_SPECIFIC (tmp) && GFC_DECL_SAVED_DESCRIPTOR (tmp))
+ tmp = GFC_DECL_SAVED_DESCRIPTOR (tmp);
+ }
else
{
/* Remove everything after the last class reference, convert the
@@ -833,6 +847,12 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
tree tmp2;
cond = gfc_conv_expr_present (e->symtree->n.sym);
+ /* parmse->pre may contain some temporary array instructions. Those must
+ only be executed when the optional argument is set, therefore add them
+ to block. */
+ gfc_add_block_to_block (&parmse->pre, &block);
+ block.head = parmse->pre.head;
+ parmse->pre.head = NULL_TREE;
tmp = gfc_finish_block (&block);
if (optional_alloc_ptr)
@@ -1039,6 +1059,8 @@ gfc_trans_class_init_assign (gfc_code *code)
been referenced. */
gfc_get_derived_type (rhs->ts.u.derived);
gfc_add_def_init_component (rhs);
+ /* The _def_init is always scalar. */
+ rhs->rank = 0;
if (code->expr1->ts.type == BT_CLASS
&& CLASS_DATA (code->expr1)->attr.dimension)
@@ -2037,8 +2059,11 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
bool return_value;
bool alternate_entry;
bool entry_master;
+ bool is_classarray;
+ bool first_time = true;
sym = expr->symtree->n.sym;
+ is_classarray = IS_CLASS_ARRAY (sym);
ss = se->ss;
if (ss != NULL)
{
@@ -2142,9 +2167,24 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
}
else if (!sym->attr.value)
{
+ /* Dereference temporaries for class array dummy arguments. */
+ if (sym->attr.dummy && is_classarray
+ && GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr)))
+ {
+ if (!se->descriptor_only)
+ se->expr = GFC_DECL_SAVED_DESCRIPTOR (se->expr);
+
+ se->expr = build_fold_indirect_ref_loc (input_location,
+ se->expr);
+ }
+
/* Dereference non-character scalar dummy arguments. */
if (sym->attr.dummy && !sym->attr.dimension
- && !(sym->attr.codimension && sym->attr.allocatable))
+ && !(sym->attr.codimension && sym->attr.allocatable)
+ && (sym->ts.type != BT_CLASS
+ || (!CLASS_DATA (sym)->attr.dimension
+ && !(CLASS_DATA (sym)->attr.codimension
+ && CLASS_DATA (sym)->attr.allocatable))))
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
@@ -2156,11 +2196,12 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
- /* Dereference non-character pointer variables.
+ /* Dereference non-character, non-class pointer variables.
These must be dummies, results, or scalars. */
- if ((sym->attr.pointer || sym->attr.allocatable
- || gfc_is_associate_pointer (sym)
- || (sym->as && sym->as->type == AS_ASSUMED_RANK))
+ if (!is_classarray
+ && (sym->attr.pointer || sym->attr.allocatable
+ || gfc_is_associate_pointer (sym)
+ || (sym->as && sym->as->type == AS_ASSUMED_RANK))
&& (sym->attr.dummy
|| sym->attr.function
|| sym->attr.result
@@ -2168,6 +2209,32 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
&& (!sym->attr.codimension || !sym->attr.allocatable))))
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
+ /* Now treat the class array pointer variables accordingly. */
+ else if (sym->ts.type == BT_CLASS
+ && sym->attr.dummy
+ && (CLASS_DATA (sym)->attr.dimension
+ || CLASS_DATA (sym)->attr.codimension)
+ && ((CLASS_DATA (sym)->as
+ && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
+ || CLASS_DATA (sym)->attr.allocatable
+ || CLASS_DATA (sym)->attr.class_pointer))
+ se->expr = build_fold_indirect_ref_loc (input_location,
+ se->expr);
+ /* And the case where a non-dummy, non-result, non-function,
+ non-allotable and non-pointer classarray is present. This case was
+ previously covered by the first if, but with introducing the
+ check non-classarray falls out there and has to be covered here
+ explicilty. */
+ else if (sym->ts.type == BT_CLASS
+ && !sym->attr.dummy
+ && !sym->attr.function
+ && !sym->attr.result
+ && (CLASS_DATA (sym)->attr.dimension
+ || CLASS_DATA (sym)->attr.codimension)
+ && !CLASS_DATA (sym)->attr.allocatable
+ && !CLASS_DATA (sym)->attr.class_pointer)
+ se->expr = build_fold_indirect_ref_loc (input_location,
+ se->expr);
}
ref = expr->ref;
@@ -2205,6 +2272,18 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
break;
case REF_COMPONENT:
+ if (first_time && is_classarray && sym->attr.dummy
+ && se->descriptor_only
+ && !CLASS_DATA (sym)->attr.allocatable
+ && !CLASS_DATA (sym)->attr.class_pointer
+ && CLASS_DATA (sym)->as
+ && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
+ && strcmp ("_data", ref->u.c.component->name) == 0)
+ /* Skip the first ref of a _data component, because for class
+ arrays that one is already done by introducing a temporary
+ array descriptor. */
+ break;
+
if (ref->u.c.sym->attr.extension)
conv_parent_component_references (se, ref);
@@ -2224,6 +2303,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
gcc_unreachable ();
break;
}
+ first_time = false;
ref = ref->next;
}
/* Pointer assignment, allocation or pass by reference. Arrays are handled
@@ -4350,7 +4430,19 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_init_se (&parmse, se);
parm_kind = ELEMENTAL;
- if (fsym && fsym->attr.value)
+ /* For all value functions or polymorphic scalar non-pointer
+ non-allocatable variables use the expression in e directly. This
+ ensures, that initializers of polymorphic entities are correctly
+ copied. */
+ if (fsym && (fsym->attr.value
+ || (e->expr_type == EXPR_VARIABLE
+ && fsym->ts.type == BT_DERIVED
+ && e->ts.type == BT_DERIVED
+ && !e->ts.u.derived->attr.dimension
+ && !e->rank
+ && (!e->symtree
+ || (!e->symtree->n.sym->attr.allocatable
+ && !e->symtree->n.sym->attr.pointer)))))
gfc_conv_expr (&parmse, e);
else
gfc_conv_expr_reference (&parmse, e);
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 9ca46ef..c899a73 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -5863,8 +5863,15 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
}
else if (arg->ts.type == BT_CLASS)
{
- if (arg->rank)
+ /* For deferred length arrays, conv_expr_descriptor returns an
+ indirect_ref to the component. */
+ if (arg->rank < 0)
byte_size = gfc_vtable_size_get (TREE_OPERAND (argse.expr, 0));
+ else if (arg->rank > 0)
+ /* The scalarizer added an additional temp. To get the class' vptr
+ one has to look at the original backend_decl. */
+ byte_size = gfc_vtable_size_get (
+ GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
else
byte_size = gfc_vtable_size_get (argse.expr);
}
@@ -5995,7 +6002,11 @@ gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
gfc_conv_expr_descriptor (&argse, arg);
if (arg->ts.type == BT_CLASS)
{
- tmp = gfc_vtable_size_get (TREE_OPERAND (argse.expr, 0));
+ if (arg->rank > 0)
+ tmp = gfc_vtable_size_get (
+ GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
+ else
+ tmp = gfc_vtable_size_get (TREE_OPERAND (argse.expr, 0));
tmp = fold_convert (result_type, tmp);
goto done;
}
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 505f905..d393a14 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -1276,12 +1276,29 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
gfc_init_se (&se, NULL);
se.descriptor_only = 1;
- gfc_conv_expr (&se, e);
+ /* In a select type the (temporary) associate variable shall point to
+ a standart fortran array (lower bound == 1), but conv_expr ()
+ just maps to the input array in the class object, whose lbound may
+ be arbitrary. conv_expr_descriptor solves this by inserting a
+ temporary array. */
+ gfc_conv_expr_descriptor (&se, e);
- gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)));
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
+ || GFC_ARRAY_TYPE_P (TREE_TYPE (se.expr)));
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)));
- gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
+ if (GFC_ARRAY_TYPE_P (TREE_TYPE (se.expr)))
+ {
+ if (INDIRECT_REF_P (se.expr))
+ tmp = TREE_OPERAND (se.expr, 0);
+ else
+ tmp = se.expr;
+
+ gfc_add_modify (&se.pre, sym->backend_decl,
+ gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (tmp)));
+ }
+ else
+ gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
if (unlimited)
{
@@ -1292,7 +1309,7 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
gfc_get_dtype (TREE_TYPE (sym->backend_decl)));
}
- gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
+ gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
gfc_finish_block (&se.post));
}
@@ -1335,9 +1352,18 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block)
}
if (need_len_assign)
{
- /* Get the _len comp from the target expr by stripping _data
- from it and adding component-ref to _len. */
- tmp = gfc_class_len_get (TREE_OPERAND (target_expr, 0));
+ if (e->symtree
+ && DECL_LANG_SPECIFIC (e->symtree->n.sym->backend_decl)
+ && GFC_DECL_SAVED_DESCRIPTOR (e->symtree->n.sym->backend_decl))
+ /* Use the original class descriptor stored in the saved
+ descriptor to get the target_expr. */
+ target_expr =
+ GFC_DECL_SAVED_DESCRIPTOR (e->symtree->n.sym->backend_decl);
+ else
+ /* Strip the _data component from the target_expr. */
+ target_expr = TREE_OPERAND (target_expr, 0);
+ /* Add a reference to the _len comp to the target expr. */
+ tmp = gfc_class_len_get (target_expr);
/* Get the component-ref for the temp structure's _len comp. */
charlen = gfc_class_len_get (se.expr);
/* Add the assign to the beginning of the the block... */
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index bce4d24..1b613c2 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1290,9 +1290,10 @@ gfc_is_nodesc_array (gfc_symbol * sym)
{
symbol_attribute *array_attr;
gfc_array_spec *as;
+ bool is_classarray = IS_CLASS_ARRAY (sym);
- array_attr = &sym->attr;
- as = sym->as;
+ array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
+ as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
gcc_assert (array_attr->dimension || array_attr->codimension);
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index b749783..fe16059 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -362,16 +362,23 @@ gfc_build_array_ref (tree base, tree offset, tree decl)
{
if (GFC_DECL_CLASS (decl))
{
- /* Allow for dummy arguments and other good things. */
- if (POINTER_TYPE_P (TREE_TYPE (decl)))
- decl = build_fold_indirect_ref_loc (input_location, decl);
-
- /* Check if '_data' is an array descriptor. If it is not,
- the array must be one of the components of the class object,
- so return a normal array reference. */
- if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (decl))))
- return build4_loc (input_location, ARRAY_REF, type, base,
- offset, NULL_TREE, NULL_TREE);
+ /* When a temporary is in place for the class array, then the original
+ class' declaration is stored in the saved descriptor. */
+ if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
+ decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
+ else
+ {
+ /* Allow for dummy arguments and other good things. */
+ if (POINTER_TYPE_P (TREE_TYPE (decl)))
+ decl = build_fold_indirect_ref_loc (input_location, decl);
+
+ /* Check if '_data' is an array descriptor. If it is not,
+ the array must be one of the components of the class object,
+ so return a normal array reference. */
+ if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (decl))))
+ return build4_loc (input_location, ARRAY_REF, type, base,
+ offset, NULL_TREE, NULL_TREE);
+ }
span = gfc_vtable_size_get (decl);
}
diff --git a/gcc/testsuite/gfortran.dg/class_array_20.f03 b/gcc/testsuite/gfortran.dg/class_array_20.f03
new file mode 100644
index 0000000..c49f7d2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_array_20.f03
@@ -0,0 +1,100 @@
+! {dg-do run}
+!
+! Test contributed by Thomas L. Clune via pr60322
+! and Antony Lewis via pr64692
+
+program class_array_20
+ implicit none
+
+ type Foo
+ end type
+
+ type(foo), dimension(2:3) :: arg
+ integer :: oneDarr(2)
+ integer :: twoDarr(2,3)
+ integer :: x, y
+ double precision :: P(2, 2)
+
+ ! Checking for PR/60322
+ call copyFromClassArray([Foo(), Foo()])
+ call copyFromClassArray(arg)
+ call copyFromClassArray(arg(:))
+
+ x= 3
+ y= 4
+ oneDarr = [x, y]
+ call W([x, y])
+ call W(oneDarr)
+ call W([3, 4])
+
+ twoDarr = reshape([3, 4, 5, 5, 6, 7], [2, 3])
+ call WtwoD(twoDarr)
+ call WtwoD(reshape([3, 4, 5, 5, 6, 7], [2, 3]))
+
+ ! Checking for PR/64692
+ P(1:2, 1) = [1.d0, 2.d0]
+ P(1:2, 2) = [3.d0, 4.d0]
+ call AddArray(P(1:2, 2))
+
+contains
+
+ subroutine copyFromClassArray(classarray)
+ class (Foo), intent(in) :: classarray(:)
+
+ if (lbound(classarray, 1) .ne. 1) call abort()
+ if (ubound(classarray, 1) .ne. 2) call abort()
+ if (size(classarray) .ne. 2) call abort()
+ end subroutine
+
+ subroutine AddArray(P)
+ class(*), target, intent(in) :: P(:)
+ class(*), pointer :: Pt(:)
+
+ allocate(Pt(1:size(P)), source= P)
+
+ select type (P)
+ type is (double precision)
+ if (abs(P(1)-3.d0) .gt. 1.d-8) call abort()
+ if (abs(P(2)-4.d0) .gt. 1.d-8) call abort()
+ class default
+ call abort()
+ end select
+
+ select type (Pt)
+ type is (double precision)
+ if (abs(Pt(1)-3.d0) .gt. 1.d-8) call abort()
+ if (abs(Pt(2)-4.d0) .gt. 1.d-8) call abort()
+ class default
+ call abort()
+ end select
+ end subroutine
+
+ subroutine W(ar)
+ class(*), intent(in) :: ar(:)
+
+ if (lbound(ar, 1) /= 1) call abort()
+ select type (ar)
+ type is (integer)
+ ! The indeces 1:2 are essential here, or else one would not
+ ! note, that the array internally starts at 0, although the
+ ! check for the lbound above went fine.
+ if (any (ar(1:2) .ne. [3, 4])) call abort()
+ class default
+ call abort()
+ end select
+ end subroutine
+
+ subroutine WtwoD(ar)
+ class(*), intent(in) :: ar(:,:)
+
+ if (any (lbound(ar) /= [1, 1])) call abort()
+ select type (ar)
+ type is (integer)
+ if (any (reshape(ar(1:2,1:3), [6]) .ne. [3, 4, 5, 5, 6, 7])) &
+ call abort()
+ class default
+ call abort()
+ end select
+ end subroutine
+end program class_array_20
+
diff --git a/gcc/testsuite/gfortran.dg/finalize_10.f90 b/gcc/testsuite/gfortran.dg/finalize_10.f90
index e042f11..32386ce 100644
--- a/gcc/testsuite/gfortran.dg/finalize_10.f90
+++ b/gcc/testsuite/gfortran.dg/finalize_10.f90
@@ -27,8 +27,8 @@ end subroutine foo
! Finalize CLASS + set default init
! { dg-final { scan-tree-dump-times "y->_vptr->_final \\(&desc.\[0-9\]+, y->_vptr->_size, 0\\);" 1 "original" } }
! { dg-final { scan-tree-dump "__builtin_memcpy \\(\\(void .\\) y->_data, \\(void .\\) y->_vptr->_def_init, \\((unsigned long|unsigned int|character\\(kind=4\\))\\) y->_vptr->_size\\);" "original" } }
-! { dg-final { scan-tree-dump-times "x->_vptr->_final \\(&x->_data, x->_vptr->_size, 0\\);" 1 "original" } }
-! { dg-final { scan-tree-dump-times "x->_vptr->_copy \\(x->_vptr->_def_init, &x->_data\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x->_vptr->_final \\(&parm.\[0-9\]+, x->_vptr->_size, 0\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "x->_vptr->_copy \\(" 1 "original" } }
! FINALIZE TYPE:
! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void \\*\\) &\\(\\*aa.\[0-9\]+\\)\\\[0\\\];" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/finalize_15.f90 b/gcc/testsuite/gfortran.dg/finalize_15.f90
index 3c18b2a..d5ba28f 100644
--- a/gcc/testsuite/gfortran.dg/finalize_15.f90
+++ b/gcc/testsuite/gfortran.dg/finalize_15.f90
@@ -9,37 +9,37 @@ module m
implicit none
type t1
- integer :: i
+ integer :: i = 1
contains
final :: fini_elem
end type t1
type, extends(t1) :: t1e
- integer :: j
+ integer :: j = 11
contains
final :: fini_elem2
end type t1e
type t2
- integer :: i
+ integer :: i = 2
contains
final :: fini_shape
end type t2
type, extends(t2) :: t2e
- integer :: j
+ integer :: j = 22
contains
final :: fini_shape2
end type t2e
type t3
- integer :: i
+ integer :: i = 3
contains
final :: fini_explicit
end type t3
type, extends(t3) :: t3e
- integer :: j
+ integer :: j = 33
contains
final :: fini_explicit2
end type t3e
@@ -204,31 +204,31 @@ program test
select type(x)
type is (t1e)
- call check_val(x%i, 1)
- call check_val(x%j, 100)
+ call check_val(x%i, 1, 1)
+ call check_val(x%j, 100, 11)
end select
select type(y)
type is (t2e)
- call check_val(y%i, 1)
- call check_val(y%j, 100)
+ call check_val(y%i, 1, 2)
+ call check_val(y%j, 100, 22)
end select
select type(z)
type is (t3e)
- call check_val(z%i, 1)
- call check_val(z%j, 100)
+ call check_val(z%i, 1, 3)
+ call check_val(z%j, 100, 33)
end select
contains
- subroutine check_val(x, factor)
+ subroutine check_val(x, factor, val)
integer :: x(:,:)
- integer, value :: factor
+ integer, value :: factor, val
integer :: i, j
do i = 1, 10
do j = 1, 10
if (mod (j-1, 2) == 0 .and. mod (i-1, 3) == 0) then
- if (x(j,i) /= (j + 100*i)*factor*(-13)) call abort ()
+ if (x(j,i) /= val) call abort ()
else
if (x(j,i) /= (j + 100*i)*factor) call abort ()
end if
diff --git a/gcc/testsuite/gfortran.dg/finalize_29.f08 b/gcc/testsuite/gfortran.dg/finalize_29.f08
new file mode 100644
index 0000000..1f5f7424
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/finalize_29.f08
@@ -0,0 +1,289 @@
+! {dg-do run}
+!
+! Testcase contributed by Andre Vehreschild <vehre@gcc.gnu.org>
+
+module module_finalize_29
+ implicit none
+
+ ! The type name is encoding the state of its finalizer being
+ ! elemental (second letter 'e'), or non-element (second letter 'n')
+ ! or array shaped (second letter 'a'), or shape-specific routine
+ ! (generic; second letter 'g'),
+ ! and whether the init-routine is elemental or not (third letter
+ ! either 'e' or 'n').
+ type ten
+ integer :: i = 40
+ contains
+ final :: ten_fin
+ end type ten
+
+ type tee
+ integer :: i = 41
+ contains
+ final :: tee_fin
+ end type tee
+
+ type tne
+ integer :: i = 42
+ contains
+ final :: tne_fin
+ end type tne
+
+ type tnn
+ integer :: i = 43
+ contains
+ final :: tnn_fin
+ end type tnn
+
+ type tae
+ integer :: i = 44
+ contains
+ final :: tae_fin
+ end type tae
+
+ type tan
+ integer :: i = 45
+ contains
+ final :: tan_fin
+ end type tan
+
+ type tge
+ integer :: i = 46
+ contains
+ final :: tge_scalar_fin, tge_array_fin
+ end type tge
+
+ type tgn
+ integer :: i = 47
+ contains
+ final :: tgn_scalar_fin, tgn_array_fin
+ end type tgn
+
+ integer :: ten_fin_counts, tee_fin_counts, tne_fin_counts, tnn_fin_counts
+ integer :: tae_fin_counts, tan_fin_counts
+ integer :: tge_scalar_fin_counts, tge_array_fin_counts
+ integer :: tgn_scalar_fin_counts, tgn_array_fin_counts
+contains
+ impure elemental subroutine ten_fin(x)
+ type(ten), intent(inout) :: x
+ x%i = -10 * x%i
+ ten_fin_counts = ten_fin_counts + 1
+ end subroutine ten_fin
+
+ impure elemental subroutine tee_fin(x)
+ type(tee), intent(inout) :: x
+ x%i = -11 * x%i
+ tee_fin_counts = tee_fin_counts + 1
+ end subroutine tee_fin
+
+ subroutine tne_fin(x)
+ type(tne), intent(inout) :: x
+ x%i = -12 * x%i
+ tne_fin_counts = tne_fin_counts + 1
+ end subroutine tne_fin
+
+ subroutine tnn_fin(x)
+ type(tnn), intent(inout) :: x
+ x%i = -13 * x%i
+ tnn_fin_counts = tnn_fin_counts + 1
+ end subroutine tnn_fin
+
+ subroutine tae_fin(x)
+ type(tae), intent(inout) :: x(:,:)
+ x%i = -14 * x%i
+ tae_fin_counts = tae_fin_counts + 1
+ end subroutine tae_fin
+
+ subroutine tan_fin(x)
+ type(tan), intent(inout) :: x(:,:)
+ x%i = -15 * x%i
+ tan_fin_counts = tan_fin_counts + 1
+ end subroutine tan_fin
+
+ subroutine tge_scalar_fin(x)
+ type(tge), intent(inout) :: x
+ x%i = -16 * x%i
+ tge_scalar_fin_counts = tge_scalar_fin_counts + 1
+ end subroutine tge_scalar_fin
+
+ subroutine tge_array_fin(x)
+ type(tge), intent(inout) :: x(:,:)
+ x%i = -17 * x%i
+ tge_array_fin_counts = tge_array_fin_counts + 1
+ end subroutine tge_array_fin
+
+ subroutine tgn_scalar_fin(x)
+ type(tgn), intent(inout) :: x
+ x%i = -18 * x%i
+ tgn_scalar_fin_counts = tgn_scalar_fin_counts + 1
+ end subroutine tgn_scalar_fin
+
+ subroutine tgn_array_fin(x)
+ type(tgn), intent(inout) :: x(:,:)
+ x%i = -19 * x%i
+ tgn_array_fin_counts = tgn_array_fin_counts + 1
+ end subroutine tgn_array_fin
+
+ ! The finalizer/initializer call producer
+ subroutine ten_init(x)
+ class(ten), intent(out) :: x(:,:)
+ end subroutine ten_init
+
+ impure elemental subroutine tee_init(x)
+ class(tee), intent(out) :: x
+ end subroutine tee_init
+
+ impure elemental subroutine tne_init(x)
+ class(tne), intent(out) :: x
+ end subroutine tne_init
+
+ subroutine tnn_init(x)
+ class(tnn), intent(out) :: x(:,:)
+ end subroutine tnn_init
+
+ impure elemental subroutine tae_init(x)
+ class(tae), intent(out) :: x
+ end subroutine tae_init
+
+ subroutine tan_init(x)
+ class(tan), intent(out) :: x(:,:)
+ end subroutine tan_init
+
+ impure elemental subroutine tge_init(x)
+ class(tge), intent(out) :: x
+ end subroutine tge_init
+
+ subroutine tgn_init(x)
+ class(tgn), intent(out) :: x(:,:)
+ end subroutine tgn_init
+end module module_finalize_29
+
+program finalize_29
+ use module_finalize_29
+ implicit none
+
+ type(ten), allocatable :: x_ten(:,:)
+ type(tee), allocatable :: x_tee(:,:)
+ type(tne), allocatable :: x_tne(:,:)
+ type(tnn), allocatable :: x_tnn(:,:)
+ type(tae), allocatable :: x_tae(:,:)
+ type(tan), allocatable :: x_tan(:,:)
+ type(tge), allocatable :: x_tge(:,:)
+ type(tgn), allocatable :: x_tgn(:,:)
+
+ ! Set the global counts to zero.
+ ten_fin_counts = 0
+ tee_fin_counts = 0
+ tne_fin_counts = 0
+ tnn_fin_counts = 0
+ tae_fin_counts = 0
+ tan_fin_counts = 0
+ tge_scalar_fin_counts = 0
+ tge_array_fin_counts = 0
+ tgn_scalar_fin_counts = 0
+ tgn_array_fin_counts = 0
+
+ allocate(ten :: x_ten(5,5))
+ allocate(tee :: x_tee(5,5))
+ allocate(tne :: x_tne(5,5))
+ allocate(tnn :: x_tnn(5,5))
+ allocate(tae :: x_tae(5,5))
+ allocate(tan :: x_tan(5,5))
+ allocate(tge :: x_tge(5,5))
+ allocate(tgn :: x_tgn(5,5))
+
+ x_ten%i = 1
+ x_tee%i = 2
+ x_tne%i = 3
+ x_tnn%i = 4
+ x_tae%i = 5
+ x_tan%i = 6
+ x_tge%i = 7
+ x_tgn%i = 8
+
+ call ten_init(x_ten(::2, ::3))
+
+ if (ten_fin_counts /= 6) call abort()
+ if (tee_fin_counts + tne_fin_counts + tnn_fin_counts + tae_fin_counts + &
+ tan_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + &
+ tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) call abort()
+ ten_fin_counts = 0
+
+ call tee_init(x_tee(::2, ::3))
+
+ if (tee_fin_counts /= 6) call abort()
+ if (ten_fin_counts + tne_fin_counts + tnn_fin_counts + tae_fin_counts + &
+ tan_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + &
+ tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) call abort()
+ tee_fin_counts = 0
+
+ call tne_init(x_tne(::2, ::3))
+
+ if (tne_fin_counts /= 6) call abort()
+ if (ten_fin_counts + tee_fin_counts + tnn_fin_counts + tae_fin_counts + &
+ tan_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + &
+ tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) call abort()
+ tne_fin_counts = 0
+
+ call tnn_init(x_tnn(::2, ::3))
+
+ if (tnn_fin_counts /= 0) call abort()
+ if (ten_fin_counts + tee_fin_counts + tne_fin_counts + tae_fin_counts + &
+ tan_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + &
+ tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) call abort()
+
+ call tae_init(x_tae(::2, ::3))
+
+ if (tae_fin_counts /= 0) call abort()
+ if (ten_fin_counts + tee_fin_counts + tne_fin_counts + tnn_fin_counts + &
+ tan_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + &
+ tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) call abort()
+
+ call tan_init(x_tan(::2, ::3))
+
+ if (tan_fin_counts /= 1) call abort()
+ if (ten_fin_counts + tee_fin_counts + tne_fin_counts + tnn_fin_counts + &
+ tae_fin_counts + tge_scalar_fin_counts + tge_array_fin_counts + &
+ tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) call abort()
+ tan_fin_counts = 0
+
+ call tge_init(x_tge(::2, ::3))
+
+ if (tge_scalar_fin_counts /= 6) call abort()
+ if (ten_fin_counts + tee_fin_counts + tne_fin_counts + tnn_fin_counts + &
+ tae_fin_counts + tan_fin_counts + tgn_array_fin_counts + &
+ tgn_scalar_fin_counts + tgn_array_fin_counts /= 0) call abort()
+ tge_scalar_fin_counts = 0
+
+ call tgn_init(x_tgn(::2, ::3))
+
+ if (tgn_array_fin_counts /= 1) call abort()
+ if (ten_fin_counts + tee_fin_counts + tne_fin_counts + tnn_fin_counts + &
+ tae_fin_counts + tan_fin_counts + tge_scalar_fin_counts + &
+ tge_array_fin_counts + tgn_scalar_fin_counts /= 0) call abort()
+ tgn_array_fin_counts = 0
+
+ if (any (reshape (x_ten%i, [25]) /= [[40, 1, 40, 1, 40], [1, 1, 1, 1, 1],&
+ [1, 1, 1, 1, 1], [40, 1, 40, 1, 40], [1, 1, 1, 1, 1]])) call abort()
+
+ if (any (reshape (x_tee%i, [25]) /= [[41, 2, 41, 2, 41], [2, 2, 2, 2, 2],&
+ [2, 2, 2, 2, 2], [41, 2, 41, 2, 41], [2, 2, 2, 2, 2]])) call abort()
+
+ if (any (reshape (x_tne%i, [25]) /= [[42, 3, 42, 3, 42], [3, 3, 3, 3, 3],&
+ [3, 3, 3, 3, 3], [42, 3, 42, 3, 42], [3, 3, 3, 3, 3]])) call abort()
+
+ if (any (reshape (x_tnn%i, [25]) /= [[43, 4, 43, 4, 43], [4, 4, 4, 4, 4],&
+ [4, 4, 4, 4, 4], [43, 4, 43, 4, 43], [4, 4, 4, 4, 4]])) call abort()
+
+ if (any (reshape (x_tae%i, [25]) /= [[44, 5, 44, 5, 44], [5, 5, 5, 5, 5],&
+ [5, 5, 5, 5, 5], [44, 5, 44, 5, 44], [5, 5, 5, 5, 5]])) call abort()
+
+ if (any (reshape (x_tan%i, [25]) /= [[45, 6, 45, 6, 45], [6, 6, 6, 6, 6],&
+ [6, 6, 6, 6, 6], [45, 6, 45, 6, 45], [6, 6, 6, 6, 6]])) call abort()
+
+ if (any (reshape (x_tge%i, [25]) /= [[46, 7, 46, 7, 46], [7, 7, 7, 7, 7],&
+ [7, 7, 7, 7, 7], [46, 7, 46, 7, 46], [7, 7, 7, 7, 7]])) call abort()
+
+ if (any (reshape (x_tgn%i, [25]) /= [[47, 8, 47, 8, 47], [8, 8, 8, 8, 8],&
+ [8, 8, 8, 8, 8], [47, 8, 47, 8, 47], [8, 8, 8, 8, 8]])) call abort()
+end program finalize_29
| Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
|---|---|---|
| Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |