+2015-04-23 Andre Vehreschild <vehre@gmx.de>
+
+ PR fortran/60322
+ * expr.c (gfc_lval_expr_from_sym): Code to select the regular
+ or class array added.
+ * gfortran.h: Add IS_CLASS_ARRAY macro.
+ * trans-array.c (gfc_add_loop_ss_code): Treat class objects
+ to be referenced always.
+ (build_class_array_ref): Adapt retrieval of array descriptor.
+ (build_array_ref): Likewise.
+ (gfc_conv_array_ref): Hand the vptr or the descriptor to
+ build_array_ref depending whether the sym is class or not.
+ (gfc_trans_array_cobounds): Select correct gfc_array_spec for
+ regular and class arrays.
+ (gfc_trans_array_bounds): Likewise.
+ (gfc_trans_dummy_array_bias): Likewise.
+ (gfc_get_dataptr_offset): Correcting call of build_array_ref.
+ (gfc_conv_expr_descriptor): Set the array's offset to -1 when
+ lbound in inner most dim is 1 and symbol non-pointer/assoc.
+ * trans-decl.c (gfc_build_qualified_array): Select correct
+ gfc_array_spec for regular and class arrays.
+ (gfc_build_dummy_array_decl): Likewise.
+ (gfc_get_symbol_decl): Get a dummy array for class arrays.
+ (gfc_trans_deferred_vars): Tell conv_expr that the descriptor
+ is desired.
+ * trans-expr.c (gfc_class_vptr_get): Get the class descriptor
+ from the correct location for class arrays.
+ (gfc_class_len_get): Likewise.
+ (gfc_conv_intrinsic_to_class): Add handling of _len component.
+ (gfc_conv_class_to_class): Prevent access to unset array data
+ when the array is an optional argument. Add handling of _len
+ component.
+ (gfc_copy_class_to_class): Check that _def_init is non-NULL
+ when used in _vptr->copy()
+ (gfc_trans_class_init_assign): Ensure that the rank of
+ _def_init is zero.
+ (gfc_conv_component_ref): Get the _vptr along with _data refs.
+ (gfc_conv_variable): Make sure the temp array descriptor is
+ returned for class arrays, too, and that class arrays are
+ dereferenced correctly.
+ (gfc_conv_procedure_call): For polymorphic type initialization
+ the initializer has to be a pointer to _def_init stored in a
+ dummy variable, which then needs to be used by value.
+ * trans-intrinsic.c (gfc_conv_intrinsic_sizeof): Use the
+ temporary array descriptor for class arrays, too.
+ (gfc_conv_intrinsic_storage_size): Likewise.
+ (gfc_conv_intrinsic_loc): Add ref to _data for BT_CLASS
+ expressions.
+ * trans-stmt.c (trans_associate_var): Use a temporary array for
+ the associate variable of class arrays, too, making the array
+ one-based (lbound == 1).
+ * trans-types.c (gfc_is_nodesc_array): Use the correct
+ array data.
+ * trans.c (gfc_build_array_ref): Use the dummy array descriptor
+ when present.
+ * trans.h: Add class_vptr to gfc_se for storing a class ref's
+ vptr.
+
2015-04-22 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/65429
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;
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;
}
&& 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 */
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
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
static tree
-build_array_ref (tree desc, tree offset, tree decl)
+build_array_ref (tree desc, tree offset, tree decl, tree vptr)
{
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);
tmp = gfc_conv_array_data (desc);
tmp = build_fold_indirect_ref_loc (input_location, tmp);
- tmp = gfc_build_array_ref (tmp, offset, decl);
+ tmp = gfc_build_array_ref (tmp, offset, decl, vptr);
return tmp;
}
offset = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, offset, cst_offset);
- se->expr = build_array_ref (se->expr, offset, sym->backend_decl);
+ se->expr = build_array_ref (se->expr, offset, sym->ts.type == BT_CLASS ?
+ NULL_TREE : sym->backend_decl, se->class_vptr);
}
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++)
{
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;
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;
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)
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]);
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);
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);
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);
return;
}
- tmp = build_array_ref (desc, offset, NULL);
+ tmp = build_array_ref (desc, offset, NULL, NULL);
/* Offset the data pointer for pointer assignments from arrays with
subreferences; e.g. my_integer => my_type(:)%integer_component. */
tree from;
tree to;
tree base;
+ bool onebased = false;
ndim = info->ref ? info->ref->u.ar.dimen : ss->dimen;
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);
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 && expr->symtree->n.sym->ts.type == BT_CLASS
+ && !CLASS_DATA (expr->symtree->n.sym)->attr.class_pointer)
+ && !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
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))
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;
}
/* 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;
}
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;
}
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);
{
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);
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.
+ For class arrays the information if sym is an allocatable or pointer
+ object needs to be checked explicitly (IS_CLASS_ARRAY can be false for
+ too many reasons to be of use 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
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
/* 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;
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)
= 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))
{
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),
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)
}
else
{
+ se.descriptor_only = 1;
gfc_conv_expr (&se, e);
descriptor = se.expr;
se.expr = gfc_conv_descriptor_data_addr (se.expr);
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)),
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)),
gfc_add_modify (&parmse->pre, ctree, tmp);
}
+ 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);
}
tree tmp;
tree vptr;
tree cond = NULL_TREE;
+ tree slen = NULL_TREE;
gfc_ref *ref;
gfc_ref *class_ref;
stmtblock_t block;
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
gfc_conv_expr (&tmpse, e);
class_ref->next = ref;
tmp = tmpse.expr;
+ slen = tmpse.string_length;
}
gcc_assert (tmp != NULL_TREE);
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)
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);
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);
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);
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;
}
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)
field = f2;
}
+ if (ref->u.c.sym && ref->u.c.sym->ts.type == BT_CLASS
+ && strcmp ("_data", c->name) == 0)
+ {
+ /* Found a ref to the _data component. Store the associated ref to
+ the vptr in se->class_vptr. */
+ se->class_vptr = gfc_class_vptr_get (decl);
+ }
+ else
+ se->class_vptr = NULL_TREE;
+
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
decl, field, NULL_TREE);
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)
{
}
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);
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
&& (!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;
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);
gcc_unreachable ();
break;
}
+ first_time = false;
ref = ref->next;
}
/* Pointer assignment, allocation or pass by reference. Arrays are handled
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);
}
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);
}
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;
}
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);
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 standard 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)
{
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));
}
}
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... */
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;
}
/* Build an ARRAY_REF with its natural type. */
tree
-gfc_build_array_ref (tree base, tree offset, tree decl)
+gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr)
{
tree type = TREE_TYPE (base);
tree tmp;
/* If the array reference is to a pointer, whose target contains a
subreference, use the span that is stored with the backend decl
and reference the element with pointer arithmetic. */
- if (decl && (TREE_CODE (decl) == FIELD_DECL
- || TREE_CODE (decl) == VAR_DECL
- || TREE_CODE (decl) == PARM_DECL)
- && ((GFC_DECL_SUBREF_ARRAY_P (decl)
- && !integer_zerop (GFC_DECL_SPAN(decl)))
+ if ((decl && (TREE_CODE (decl) == FIELD_DECL
+ || TREE_CODE (decl) == VAR_DECL
+ || TREE_CODE (decl) == PARM_DECL)
+ && ((GFC_DECL_SUBREF_ARRAY_P (decl)
+ && !integer_zerop (GFC_DECL_SPAN (decl)))
|| GFC_DECL_CLASS (decl)))
+ || vptr)
{
- if (GFC_DECL_CLASS (decl))
+ if (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);
-
- span = gfc_class_vtab_size_get (decl);
+ if (GFC_DECL_CLASS (decl))
+ {
+ /* 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);
+ }
+ else if (GFC_DECL_SUBREF_ARRAY_P (decl))
+ span = GFC_DECL_SPAN (decl);
+ else
+ gcc_unreachable ();
}
- else if (GFC_DECL_SUBREF_ARRAY_P (decl))
- span = GFC_DECL_SPAN(decl);
+ else if (vptr)
+ span = gfc_vptr_size_get (vptr);
else
gcc_unreachable ();
/* The length of a character string value. */
tree string_length;
+ /* When expr is a reference to a class object, store its vptr access
+ here. */
+ tree class_vptr;
+
/* If set gfc_conv_variable will return an expression for the array
descriptor. When set, want_pointer should also be set.
If not set scalarizing variables will be substituted. */
tree gfc_build_addr_expr (tree, tree);
/* Build an ARRAY_REF. */
-tree gfc_build_array_ref (tree, tree, tree);
+tree gfc_build_array_ref (tree, tree, tree, tree vptr = NULL_TREE);
/* Creates a label. Decl is artificial if label_id == NULL_TREE. */
tree gfc_build_label_decl (tree);
+2015-04-23 Andre Vehreschild <vehre@gmx.de>
+
+ PR fortran/60322
+ * gfortran.dg/class_allocate_19.f03: New test.
+ * gfortran.dg/class_array_20.f03: New test.
+ * gfortran.dg/class_array_21.f03: New test.
+ * gfortran.dg/finalize_10.f90: Corrected scan-trees.
+ * gfortran.dg/finalize_15.f90: Fixing comparision to model
+ initialization correctly.
+ * gfortran.dg/finalize_29.f08: New test.
+
2015-04-22 Bill Schmidt <wschmidt@linux.vnet.ibm.com>
* gcc.target/powerpc/swaps-p8-18.c: New test.
! 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" } }
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
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
projects / gcc.git / commitdiff