@@ -4052,6 +4052,7 @@ gfc_expr *
gfc_lval_expr_from_sym (gfc_symbol *sym)
{
gfc_expr *lval;
+ gfc_array_spec *as;
lval = gfc_get_expr ();
lval->expr_type = EXPR_VARIABLE;
lval->where = sym->declared_at;
@@ -4059,10 +4060,10 @@ 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. */
- lval->rank = sym->as ? sym->as->rank : 0;
+ 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, sym->ts.type == BT_CLASS ?
- CLASS_DATA (sym)->as : sym->as);
+ gfc_add_full_array_ref (lval, as);
return lval;
}
@@ -3206,6 +3206,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 */
@@ -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);
@@ -5570,7 +5595,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++)
{
@@ -5613,7 +5638,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;
@@ -5900,12 +5925,17 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
int checkparm;
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->ts.type != BT_CLASS && sym->attr.pointer)
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_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;
@@ -5918,14 +5948,20 @@ 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);
+ 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
&& TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
- checkparm = (sym->as->type == AS_EXPLICIT
+ checkparm = (as->type == AS_EXPLICIT
&& (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS));
no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
@@ -6001,9 +6037,9 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
size = gfc_index_one_node;
/* Evaluate the bounds of the array. */
- for (n = 0; n < sym->as->rank; n++)
+ for (n = 0; n < as->rank; n++)
{
- if (checkparm || !sym->as->upper[n])
+ if (checkparm || !as->upper[n])
{
/* Get the bounds of the actual parameter. */
dubound = gfc_conv_descriptor_ubound_get (dumdesc, gfc_rank_cst[n]);
@@ -6019,7 +6055,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
if (!INTEGER_CST_P (lbound))
{
gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, sym->as->lower[n],
+ gfc_conv_expr_type (&se, as->lower[n],
gfc_array_index_type);
gfc_add_block_to_block (&init, &se.pre);
gfc_add_modify (&init, lbound, se.expr);
@@ -6027,13 +6063,13 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
ubound = GFC_TYPE_ARRAY_UBOUND (type, n);
/* Set the desired upper bound. */
- if (sym->as->upper[n])
+ if (as->upper[n])
{
/* We know what we want the upper bound to be. */
if (!INTEGER_CST_P (ubound))
{
gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, sym->as->upper[n],
+ gfc_conv_expr_type (&se, as->upper[n],
gfc_array_index_type);
gfc_add_block_to_block (&init, &se.pre);
gfc_add_modify (&init, ubound, se.expr);
@@ -6086,7 +6122,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
gfc_array_index_type, offset, tmp);
/* The size of this dimension, and the stride of the next. */
- if (n + 1 < sym->as->rank)
+ if (n + 1 < as->rank)
{
stride = GFC_TYPE_ARRAY_STRIDE (type, n + 1);
@@ -6789,6 +6825,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 +6967,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 +7024,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
@@ -812,8 +812,13 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
int dim;
int nest;
gfc_namespace* procns;
+ symbol_attribute *array_attr;
+ gfc_array_spec *as;
+ bool is_classarray = IS_CLASS_ARRAY (sym);
type = TREE_TYPE (decl);
+ 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))
@@ -824,8 +829,8 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
nest = (procns->proc_name->backend_decl != current_function_decl)
&& !sym->attr.contained;
- if (sym->attr.codimension && flag_coarray == GFC_FCOARRAY_LIB
- && sym->as->type != AS_ASSUMED_SHAPE
+ if (array_attr->codimension && flag_coarray == GFC_FCOARRAY_LIB
+ && as->type != AS_ASSUMED_SHAPE
&& GFC_TYPE_ARRAY_CAF_TOKEN (type) == NULL_TREE)
{
tree token;
@@ -878,8 +883,8 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
}
/* Don't try to use the unknown bound for assumed shape arrays. */
if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
- && (sym->as->type != AS_ASSUMED_SIZE
- || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
+ && (as->type != AS_ASSUMED_SIZE
+ || dim < GFC_TYPE_ARRAY_RANK (type) - 1))
{
GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
@@ -920,7 +925,7 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
}
if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
- && sym->as->type != AS_ASSUMED_SIZE)
+ && as->type != AS_ASSUMED_SIZE)
{
GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
@@ -947,12 +952,12 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
}
if (TYPE_NAME (type) != NULL_TREE
- && GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE
- && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL)
+ && GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1) != NULL_TREE
+ && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1)) == VAR_DECL)
{
tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
- for (dim = 0; dim < sym->as->rank - 1; dim++)
+ for (dim = 0; dim < as->rank - 1; dim++)
{
gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
gtype = TREE_TYPE (gtype);
@@ -966,7 +971,7 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
{
tree gtype = TREE_TYPE (type), rtype, type_decl;
- for (dim = sym->as->rank - 1; dim >= 0; dim--)
+ for (dim = as->rank - 1; dim >= 0; dim--)
{
tree lbound, ubound;
lbound = GFC_TYPE_ARRAY_LBOUND (type, dim);
@@ -1014,41 +1019,56 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
tree decl;
tree type;
gfc_array_spec *as;
+ symbol_attribute *array_attr;
char *name;
gfc_packed packed;
int n;
bool known_size;
-
- if (sym->attr.pointer || sym->attr.allocatable
- || (sym->as && sym->as->type == AS_ASSUMED_RANK))
+ bool is_classarray = IS_CLASS_ARRAY (sym);
+
+ /* Use the array as and attr. */
+ as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
+ array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
+
+ /* The dummy is returned for pointer, allocatable or assumed rank arrays.
+ The check for pointerness needs to be repeated here (it is done in
+ IS_CLASS_ARRAY (), too), because for class arrays that are pointers, as
+ is the one of the sym, which is incorrect here. */
+ if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
+ || array_attr->allocatable
+ || (as && as->type == AS_ASSUMED_RANK))
return dummy;
- /* Add to list of variables if not a fake result variable. */
+ /* Add to list of variables if not a fake result variable.
+ These symbols are set on the symbol only, not on the class component. */
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. */
- as = sym->as;
packed = PACKED_NO;
/* Even when -frepack-arrays is used, symbols with TARGET attribute
@@ -1079,8 +1099,11 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
packed = PACKED_PARTIAL;
}
- type = gfc_typenode_for_spec (&sym->ts);
- type = gfc_get_nodesc_array_type (type, sym->as, packed,
+ /* 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);
}
else
@@ -1110,7 +1133,7 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
/* We should never get deferred shape arrays here. We used to because of
frontend bugs. */
- gcc_assert (sym->as->type != AS_DEFERRED);
+ gcc_assert (as->type != AS_DEFERRED);
if (packed == PACKED_PARTIAL)
GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
@@ -1429,13 +1452,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 is then
+ 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)
@@ -3976,18 +4016,31 @@ 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))
{
- /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */
- array_type tmp = sym->as->type;
- if (tmp == AS_ASSUMED_SIZE && sym->as->cp_was_assumed)
- tmp = AS_EXPLICIT;
- switch (tmp)
+ bool is_classarray = IS_CLASS_ARRAY (sym);
+ symbol_attribute *array_attr;
+ gfc_array_spec *as;
+ array_type tmp;
+
+ 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)
+ tmp = AS_EXPLICIT;
+ switch (tmp)
{
case AS_EXPLICIT:
if (sym->attr.dummy || sym->attr.result)
gfc_trans_dummy_array_bias (sym, sym->backend_decl, block);
- else if (sym->attr.pointer || sym->attr.allocatable)
+ /* Allocatable and pointer arrays need to processed
+ explicitly. */
+ else if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
+ || (sym->ts.type == BT_CLASS
+ && CLASS_DATA (sym)->attr.class_pointer)
+ || array_attr->allocatable)
{
if (TREE_STATIC (sym->backend_decl))
{
@@ -4002,7 +4055,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
gfc_trans_deferred_array (sym, block);
}
}
- else if (sym->attr.codimension && TREE_STATIC (sym->backend_decl))
+ else if (sym->attr.codimension
+ && TREE_STATIC (sym->backend_decl))
{
gfc_init_block (&tmpblock);
gfc_trans_array_cobounds (TREE_TYPE (sym->backend_decl),
@@ -4041,7 +4095,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
case AS_ASSUMED_SIZE:
/* Must be a dummy parameter. */
- gcc_assert (sym->attr.dummy || sym->as->cp_was_assumed);
+ gcc_assert (sym->attr.dummy || as->cp_was_assumed);
/* We should always pass assumed size arrays the g77 way. */
if (sym->attr.dummy)
@@ -4103,6 +4157,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);
@@ -149,6 +149,11 @@ tree
gfc_class_vptr_get (tree decl)
{
tree vptr;
+ /* For class arrays decl may be a temporary descriptor handle, the vptr is
+ then 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 descriptor handle, the len is
+ then 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)),
@@ -766,6 +776,16 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
}
}
}
+ else if (class_ts.type == BT_CLASS
+ && class_ts.u.derived->components
+ && class_ts.u.derived->components->ts.u
+ .derived->attr.unlimited_polymorphic)
+ {
+ ctree = gfc_class_len_get (var);
+ gfc_add_modify (&parmse->pre, ctree,
+ fold_convert (TREE_TYPE (ctree),
+ integer_zero_node));
+ }
/* Pass the address of the class object. */
parmse->expr = gfc_build_addr_expr (NULL_TREE, var);
}
@@ -792,6 +812,7 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
tree tmp;
tree vptr;
tree cond = NULL_TREE;
+ tree slen = NULL_TREE;
gfc_ref *ref;
gfc_ref *class_ref;
stmtblock_t block;
@@ -883,7 +904,12 @@ 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);
+ slen = integer_zero_node;
+ }
else
{
/* Remove everything after the last class reference, convert the
@@ -895,6 +921,7 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
gfc_conv_expr (&tmpse, e);
class_ref->next = ref;
tmp = tmpse.expr;
+ slen = tmpse.string_length;
}
gcc_assert (tmp != NULL_TREE);
@@ -913,11 +940,38 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
gfc_add_modify (&parmse->post, vptr,
fold_convert (TREE_TYPE (vptr), ctree));
+ /* For unlimited polymorphic objects also set the _len component. */
+ if (class_ts.type == BT_CLASS
+ && class_ts.u.derived->components
+ && class_ts.u.derived->components->ts.u
+ .derived->attr.unlimited_polymorphic)
+ {
+ ctree = gfc_class_len_get (var);
+ if (UNLIMITED_POLY (e))
+ tmp = gfc_class_len_get (tmp);
+ else if (e->ts.type == BT_CHARACTER)
+ {
+ gcc_assert (slen != NULL_TREE);
+ tmp = slen;
+ }
+ else
+ tmp = integer_zero_node;
+ gfc_add_modify (&parmse->pre, ctree,
+ fold_convert (TREE_TYPE (ctree), tmp));
+ }
+
if (optional)
{
tree tmp2;
cond = gfc_conv_expr_present (e->symtree->n.sym);
+ /* parmse->pre may contain some preparatory instructions for the
+ temporary array descriptor. Those may only be executed when the
+ optional argument is set, therefore add parmse->pre's instructions
+ to block, which is later guarded by an if (optional_arg_given). */
+ 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)
@@ -1004,7 +1058,7 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
fcn_type = TREE_TYPE (TREE_TYPE (fcn));
if (from != NULL_TREE)
- from_data = gfc_class_data_get (from);
+ from_data = gfc_class_data_get (from);
else
from_data = gfc_class_vtab_def_init_get (to);
@@ -1061,7 +1115,8 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
gfc_init_block (&ifbody);
gfc_add_block_to_block (&ifbody, &loop.pre);
stdcopy = gfc_finish_block (&ifbody);
- if (unlimited)
+ /* In initialization mode from_len is a constant zero. */
+ if (unlimited && !integer_zerop (from_len))
{
vec_safe_push (args, from_len);
vec_safe_push (args, to_len);
@@ -1103,7 +1158,8 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
vec_safe_push (args, to_data);
stdcopy = build_call_vec (fcn_type, fcn, args);
- if (unlimited)
+ /* In initialization mode from_len is a constant zero. */
+ if (unlimited && !integer_zerop (from_len))
{
vec_safe_push (args, from_len);
vec_safe_push (args, to_len);
@@ -1118,6 +1174,18 @@ gfc_copy_class_to_class (tree from, tree to, tree nelems, bool unlimited)
tmp = stdcopy;
}
+ /* Only copy _def_init to to_data, when it is not a NULL-pointer. */
+ if (from == NULL_TREE)
+ {
+ tree cond;
+ cond = fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node,
+ from_data, null_pointer_node);
+ tmp = fold_build3_loc (input_location, COND_EXPR,
+ void_type_node, cond,
+ tmp, build_empty_stmt (input_location));
+ }
+
return tmp;
}
@@ -1191,6 +1259,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)
@@ -2246,8 +2316,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)
{
@@ -2351,9 +2424,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);
@@ -2365,11 +2453,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
@@ -2377,6 +2466,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
+ condition !is_classarray there, that case has to be covered
+ explicitly. */
+ 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;
@@ -2414,6 +2529,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);
@@ -2433,6 +2560,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
@@ -4559,7 +4687,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);
@@ -5921,8 +5921,17 @@ 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
+ || (arg->rank > 0 && !VAR_P (argse.expr)
+ && GFC_DECL_CLASS (TREE_OPERAND (argse.expr, 0))))
byte_size = gfc_class_vtab_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_class_vtab_size_get (
+ GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
else
byte_size = gfc_class_vtab_size_get (argse.expr);
}
@@ -6053,7 +6062,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_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
+ if (arg->rank > 0)
+ tmp = gfc_class_vtab_size_get (
+ GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
+ else
+ tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
tmp = fold_convert (result_type, tmp);
goto done;
}
@@ -7080,7 +7093,11 @@ gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
arg_expr = expr->value.function.actual->expr;
if (arg_expr->rank == 0)
- gfc_conv_expr_reference (se, arg_expr);
+ {
+ if (arg_expr->ts.type == BT_CLASS)
+ gfc_add_component_ref (arg_expr, "_data");
+ gfc_conv_expr_reference (se, arg_expr);
+ }
else
gfc_conv_array_parameter (se, arg_expr, true, NULL, NULL, NULL);
se->expr = convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
@@ -1260,12 +1260,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 descriptor. */
+ 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)
{
@@ -1276,7 +1293,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));
}
@@ -1319,9 +1336,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... */
@@ -1288,25 +1288,35 @@ gfc_get_element_type (tree type)
int
gfc_is_nodesc_array (gfc_symbol * sym)
{
- gcc_assert (sym->attr.dimension || sym->attr.codimension);
+ symbol_attribute *array_attr;
+ gfc_array_spec *as;
+ bool is_classarray = IS_CLASS_ARRAY (sym);
+
+ 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);
/* We only want local arrays. */
- if (sym->attr.pointer || sym->attr.allocatable)
+ if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer)
+ || array_attr->allocatable)
return 0;
/* We want a descriptor for associate-name arrays that do not have an
- explicitly known shape already. */
- if (sym->assoc && sym->as->type != AS_EXPLICIT)
+ explicitly known shape already. */
+ if (sym->assoc && as->type != AS_EXPLICIT)
return 0;
+ /* The dummy is stored in sym and not in the component. */
if (sym->attr.dummy)
- return sym->as->type != AS_ASSUMED_SHAPE
- && sym->as->type != AS_ASSUMED_RANK;
+ return as->type != AS_ASSUMED_SHAPE
+ && as->type != AS_ASSUMED_RANK;
if (sym->attr.result || sym->attr.function)
return 0;
- gcc_assert (sym->as->type == AS_EXPLICIT || sym->as->cp_was_assumed);
+ gcc_assert (as->type == AS_EXPLICIT || as->cp_was_assumed);
return 1;
}
@@ -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_class_vtab_size_get (decl);
}
new file mode 100644
@@ -0,0 +1,47 @@
+! { dg-do run }
+!
+! Contributed by: Vladimir Fuka <vladimir.fuka@gmail.com>
+
+use iso_c_binding
+implicit none
+real, target :: e
+class(*), allocatable, target :: a(:)
+e = 1.0
+call add_element_poly(a,e)
+if (size(a) /= 1) call abort()
+call add_element_poly(a,e)
+if (size(a) /= 2) call abort()
+select type (a)
+ type is (real)
+ if (any (a /= [ 1, 1])) call abort()
+end select
+contains
+ subroutine add_element_poly(a,e)
+ use iso_c_binding
+ class(*),allocatable,intent(inout),target :: a(:)
+ class(*),intent(in),target :: e
+ class(*),allocatable,target :: tmp(:)
+ type(c_ptr) :: dummy
+
+ interface
+ function memcpy(dest,src,n) bind(C,name="memcpy") result(res)
+ import
+ type(c_ptr) :: res
+ integer(c_intptr_t),value :: dest
+ integer(c_intptr_t),value :: src
+ integer(c_size_t),value :: n
+ end function
+ end interface
+
+ if (.not.allocated(a)) then
+ allocate(a(1), source=e)
+ else
+ allocate(tmp(size(a)),source=a)
+ deallocate(a)
+ allocate(a(size(tmp)+1),mold=e)
+ dummy = memcpy(loc(a(1)),loc(tmp),sizeof(tmp))
+ dummy = memcpy(loc(a(size(tmp)+1)),loc(e),sizeof(e))
+ end if
+ end subroutine
+end
+
new file mode 100644
@@ -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
+
@@ -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" } }
@@ -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
new file mode 100644
@@ -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