OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

PF fortran/60322

Browse Source 
gcc/testsuite/ChangeLog:

2015-04-23  Andre Vehreschild  <vehre@gmx.de>

	PF 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.


gcc/fortran/ChangeLog:

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.

From-SVN: r222361
This commit is contained in:
Andre Vehreschild 2015-04-23 13:32:00 +02:00 committed by Andre Vehreschild
parent eff973a26b
commit f3b0bb7a56
14 changed files with 538 additions and 129 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
gcc/fortran/ChangeLog
View File

@ -1,3 +1,61 @@
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

7
gcc/fortran/expr.c
View File

@ -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;
}

5
gcc/fortran/gfortran.h
View File

@ -3210,6 +3210,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 */

117
gcc/fortran/trans-array.c
View File

@ -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
@ -3155,30 +3165,45 @@ add_to_offset (tree *cst_offset, tree *offset, tree t)
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);
@ -3187,7 +3212,7 @@ build_array_ref (tree desc, tree offset, tree decl)
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;
}
@ -3350,7 +3375,8 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
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);
}
@ -5570,7 +5596,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 +5639,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 +5926,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 +5949,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 +6038,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 +6056,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 +6064,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 +6123,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);
@ -6234,7 +6271,7 @@ gfc_get_dataptr_offset (stmtblock_t *block, tree parm, tree desc, tree offset,
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. */
@ -6789,6 +6826,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 +6968,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 +7025,29 @@ 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 && 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

117
gcc/fortran/trans-decl.c
View File

@ -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;
bool is_classarray = IS_CLASS_ARRAY (sym);
if (sym->attr.pointer || sym->attr.allocatable
|| (sym->as && sym->as->type == AS_ASSUMED_RANK))
/* 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
@ -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);

170
gcc/fortran/trans-expr.c
View File

@ -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)),
@ -804,6 +814,16 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
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);
}
@ -830,6 +850,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;
@ -921,7 +942,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
@ -933,6 +959,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);
@ -951,11 +978,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)
@ -1042,7 +1096,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);
@ -1099,7 +1153,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);
@ -1141,7 +1196,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);
@ -1156,6 +1212,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;
}
@ -1229,6 +1297,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)
@ -2203,6 +2273,16 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
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);
@ -2284,8 +2364,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)
{
@ -2389,9 +2472,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);
@ -2403,11 +2501,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
@ -2415,6 +2514,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;
@ -2452,6 +2577,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);
@ -2471,6 +2608,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
@ -4597,7 +4735,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);

23
gcc/fortran/trans-intrinsic.c
View File

@ -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);

40
gcc/fortran/trans-stmt.c
View File

@ -1390,12 +1390,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 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)
{
@ -1406,7 +1423,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));
}
@ -1449,9 +1466,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... */

24
gcc/fortran/trans-types.c
View File

@ -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;
}

55
gcc/fortran/trans.c
View File

@ -321,7 +321,7 @@ gfc_build_addr_expr (tree type, tree t)
/* 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;
@ -353,30 +353,47 @@ gfc_build_array_ref (tree base, tree offset, tree decl)
/* 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);
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);
/* 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);
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 ();

6
gcc/fortran/trans.h
View File

@ -49,6 +49,10 @@ typedef struct gfc_se
/* 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. */
@ -528,7 +532,7 @@ tree gfc_get_function_decl (gfc_symbol *);
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);

11
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,14 @@
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.

4
gcc/testsuite/gfortran.dg/finalize_10.f90
View File

@ -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" } }

30
gcc/testsuite/gfortran.dg/finalize_15.f90
View File

@ -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