PR fortran/PR53876 PR fortran/PR54990 PR fortran/PR54992
2013-01-06 Paul Thomas <pault@gcc.gnu.org> PR fortran/PR53876 PR fortran/PR54990 PR fortran/PR54992 * trans-array.c (build_array_ref): Check the TYPE_CANONICAL to see if it is GFC_CLASS_TYPE_P. * trans-expr.c (gfc_get_vptr_from_expr): The same. (gfc_conv_class_to_class): If the types are not the same, cast parmese->expr to the type of ctree. * trans-types.c (gfc_get_derived_type): GFC_CLASS_TYPE_P of CLASS components must be set. 2013-01-06 Paul Thomas <pault@gcc.gnu.org> PR fortran/PR53876 PR fortran/PR54990 PR fortran/PR54992 * gfortran.dg/class_array_15.f03: New test. From-SVN: r194953
This commit is contained in:
Paul Thomas
parent
1ab05c31a0
commit
f04986a90b
6 changed files with 247 additions and 77 deletions
|
|
@ -1,3 +1,16 @@
|
|||
2013-01-06 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/PR53876
|
||||
PR fortran/PR54990
|
||||
PR fortran/PR54992
|
||||
* trans-array.c (build_array_ref): Check the TYPE_CANONICAL
|
||||
to see if it is GFC_CLASS_TYPE_P.
|
||||
* trans-expr.c (gfc_get_vptr_from_expr): The same.
|
||||
(gfc_conv_class_to_class): If the types are not the same,
|
||||
cast parmese->expr to the type of ctree.
|
||||
* trans-types.c (gfc_get_derived_type): GFC_CLASS_TYPE_P of
|
||||
CLASS components must be set.
|
||||
|
||||
2013-01-06 Mikael Morin <mikael@gcc.gnu.org>
|
||||
|
||||
PR fortran/42769
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
/* Array translation routines
|
||||
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
|
||||
2011, 2012
|
||||
2011, 2012, 2013
|
||||
Free Software Foundation, Inc.
|
||||
Contributed by Paul Brook <paul@nowt.org>
|
||||
and Steven Bosscher <s.bosscher@student.tudelft.nl>
|
||||
|
|
@ -159,7 +159,7 @@ gfc_conv_descriptor_data_get (tree desc)
|
|||
/* This provides WRITE access to the data field.
|
||||
|
||||
TUPLES_P is true if we are generating tuples.
|
||||
|
||||
|
||||
This function gets called through the following macros:
|
||||
gfc_conv_descriptor_data_set
|
||||
gfc_conv_descriptor_data_set. */
|
||||
|
|
@ -593,7 +593,7 @@ gfc_get_temp_ss (tree type, tree string_length, int dimen)
|
|||
|
||||
return ss;
|
||||
}
|
||||
|
||||
|
||||
|
||||
/* Creates and initializes a scalar type gfc_ss struct. */
|
||||
|
||||
|
|
@ -1363,7 +1363,7 @@ gfc_put_offset_into_var (stmtblock_t * pblock, tree * poffset,
|
|||
|
||||
/* Variables needed for bounds-checking. */
|
||||
static bool first_len;
|
||||
static tree first_len_val;
|
||||
static tree first_len_val;
|
||||
static bool typespec_chararray_ctor;
|
||||
|
||||
static void
|
||||
|
|
@ -2206,7 +2206,7 @@ trans_array_constructor (gfc_ss * ss, locus * where)
|
|||
|
||||
if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
|
||||
&& expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
|
||||
{
|
||||
{
|
||||
first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
|
||||
first_len = true;
|
||||
}
|
||||
|
|
@ -2217,7 +2217,7 @@ trans_array_constructor (gfc_ss * ss, locus * where)
|
|||
if (expr->ts.type == BT_CHARACTER)
|
||||
{
|
||||
bool const_string;
|
||||
|
||||
|
||||
/* get_array_ctor_strlen walks the elements of the constructor, if a
|
||||
typespec was given, we already know the string length and want the one
|
||||
specified there. */
|
||||
|
|
@ -2924,9 +2924,9 @@ conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
|
|||
gcc_assert (se->loop);
|
||||
index = se->loop->loopvar[se->loop->order[i]];
|
||||
|
||||
/* Pointer functions can have stride[0] different from unity.
|
||||
/* Pointer functions can have stride[0] different from unity.
|
||||
Use the stride returned by the function call and stored in
|
||||
the descriptor for the temporary. */
|
||||
the descriptor for the temporary. */
|
||||
if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
|
||||
&& se->ss->info->expr
|
||||
&& se->ss->info->expr->symtree
|
||||
|
|
@ -2986,7 +2986,7 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
|
|||
ts = &ref->u.c.component->ts;
|
||||
class_ref = ref;
|
||||
break;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if (ts == NULL)
|
||||
|
|
@ -3099,31 +3099,40 @@ static tree
|
|||
build_array_ref (tree desc, tree offset, tree decl)
|
||||
{
|
||||
tree tmp;
|
||||
tree type;
|
||||
|
||||
/* 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)
|
||||
{
|
||||
type = TREE_TYPE (TREE_OPERAND (desc, 0));
|
||||
if (TYPE_CANONICAL (type)
|
||||
&& GFC_CLASS_TYPE_P (TYPE_CANONICAL (type)))
|
||||
type = TYPE_CANONICAL (type);
|
||||
}
|
||||
else
|
||||
type = NULL;
|
||||
|
||||
/* Class array references need special treatment because the assigned
|
||||
type size needs to be used to point to the element. */
|
||||
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
|
||||
&& TREE_CODE (desc) == COMPONENT_REF
|
||||
&& GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0))))
|
||||
type size needs to be used to point to the element. */
|
||||
if (type && GFC_CLASS_TYPE_P (type))
|
||||
{
|
||||
tree type = gfc_get_element_type (TREE_TYPE (desc));
|
||||
type = gfc_get_element_type (TREE_TYPE (desc));
|
||||
tmp = TREE_OPERAND (desc, 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);
|
||||
}
|
||||
else
|
||||
{
|
||||
tmp = gfc_conv_array_data (desc);
|
||||
tmp = build_fold_indirect_ref_loc (input_location, tmp);
|
||||
tmp = gfc_build_array_ref (tmp, offset, decl);
|
||||
return tmp;
|
||||
}
|
||||
|
||||
tmp = gfc_conv_array_data (desc);
|
||||
tmp = build_fold_indirect_ref_loc (input_location, tmp);
|
||||
tmp = gfc_build_array_ref (tmp, offset, decl);
|
||||
return tmp;
|
||||
}
|
||||
|
||||
|
||||
|
||||
/* Build an array reference. se->expr already holds the array descriptor.
|
||||
This should be either a variable, indirect variable reference or component
|
||||
reference. For arrays which do not have a descriptor, se->expr will be
|
||||
|
|
@ -3202,7 +3211,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
|
|||
tmp = tmpse.expr;
|
||||
}
|
||||
|
||||
cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
|
||||
cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
|
||||
indexse.expr, tmp);
|
||||
asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
|
||||
"below lower bound of %%ld", n+1, sym->name);
|
||||
|
|
@ -3964,8 +3973,8 @@ done:
|
|||
stride_pos, stride_neg);
|
||||
|
||||
/* Check the start of the range against the lower and upper
|
||||
bounds of the array, if the range is not empty.
|
||||
If upper bound is present, include both bounds in the
|
||||
bounds of the array, if the range is not empty.
|
||||
If upper bound is present, include both bounds in the
|
||||
error message. */
|
||||
if (check_upper)
|
||||
{
|
||||
|
|
@ -4012,7 +4021,7 @@ done:
|
|||
fold_convert (long_integer_type_node, lbound));
|
||||
free (msg);
|
||||
}
|
||||
|
||||
|
||||
/* Compute the last element of the range, which is not
|
||||
necessarily "end" (think 0:5:3, which doesn't contain 5)
|
||||
and check it against both lower and upper bounds. */
|
||||
|
|
@ -4041,12 +4050,12 @@ done:
|
|||
gfc_trans_runtime_check (true, false, tmp2, &inner,
|
||||
expr_loc, msg,
|
||||
fold_convert (long_integer_type_node, tmp),
|
||||
fold_convert (long_integer_type_node, ubound),
|
||||
fold_convert (long_integer_type_node, ubound),
|
||||
fold_convert (long_integer_type_node, lbound));
|
||||
gfc_trans_runtime_check (true, false, tmp3, &inner,
|
||||
expr_loc, msg,
|
||||
fold_convert (long_integer_type_node, tmp),
|
||||
fold_convert (long_integer_type_node, ubound),
|
||||
fold_convert (long_integer_type_node, ubound),
|
||||
fold_convert (long_integer_type_node, lbound));
|
||||
free (msg);
|
||||
}
|
||||
|
|
@ -4885,7 +4894,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
|
|||
ubound = lower[n];
|
||||
}
|
||||
}
|
||||
gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
|
||||
gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
|
||||
gfc_rank_cst[n], se.expr);
|
||||
conv_lbound = se.expr;
|
||||
|
||||
|
|
@ -4916,11 +4925,11 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
|
|||
/* Check whether multiplying the stride by the number of
|
||||
elements in this dimension would overflow. We must also check
|
||||
whether the current dimension has zero size in order to avoid
|
||||
division by zero.
|
||||
division by zero.
|
||||
*/
|
||||
tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
|
||||
gfc_array_index_type,
|
||||
fold_convert (gfc_array_index_type,
|
||||
tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
|
||||
gfc_array_index_type,
|
||||
fold_convert (gfc_array_index_type,
|
||||
TYPE_MAX_VALUE (gfc_array_index_type)),
|
||||
size);
|
||||
cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
|
||||
|
|
@ -4935,7 +4944,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
|
|||
tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
|
||||
*overflow, tmp);
|
||||
*overflow = gfc_evaluate_now (tmp, pblock);
|
||||
|
||||
|
||||
/* Multiply the stride by the number of elements in this dimension. */
|
||||
stride = fold_build2_loc (input_location, MULT_EXPR,
|
||||
gfc_array_index_type, stride, size);
|
||||
|
|
@ -4966,7 +4975,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
|
|||
ubound = lower[n];
|
||||
}
|
||||
}
|
||||
gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
|
||||
gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
|
||||
gfc_rank_cst[n], se.expr);
|
||||
|
||||
if (n < rank + corank - 1)
|
||||
|
|
@ -5019,7 +5028,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
|
|||
/* First check for overflow. Since an array of type character can
|
||||
have zero element_size, we must check for that before
|
||||
dividing. */
|
||||
tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
|
||||
tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
|
||||
size_type_node,
|
||||
TYPE_MAX_VALUE (size_type_node), element_size);
|
||||
cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR,
|
||||
|
|
@ -5210,7 +5219,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
|
|||
{
|
||||
cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
|
||||
boolean_type_node, var_overflow, integer_zero_node));
|
||||
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
|
||||
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
|
||||
error, gfc_finish_block (&elseblock));
|
||||
}
|
||||
else
|
||||
|
|
@ -5221,7 +5230,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
|
|||
if (expr->ts.type == BT_CLASS)
|
||||
{
|
||||
tmp = build_int_cst (unsigned_char_type_node, 0);
|
||||
/* With class objects, it is best to play safe and null the
|
||||
/* With class objects, it is best to play safe and null the
|
||||
memory because we cannot know if dynamic types have allocatable
|
||||
components or not. */
|
||||
tmp = build_call_expr_loc (input_location,
|
||||
|
|
@ -5233,7 +5242,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
|
|||
/* Update the array descriptors. */
|
||||
if (dimension)
|
||||
gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
|
||||
|
||||
|
||||
set_descriptor = gfc_finish_block (&set_descriptor_block);
|
||||
if (status != NULL_TREE)
|
||||
{
|
||||
|
|
@ -5243,7 +5252,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
|
|||
gfc_add_expr_to_block (&se->pre,
|
||||
fold_build3_loc (input_location, COND_EXPR, void_type_node,
|
||||
gfc_likely (cond), set_descriptor,
|
||||
build_empty_stmt (input_location)));
|
||||
build_empty_stmt (input_location)));
|
||||
}
|
||||
else
|
||||
gfc_add_expr_to_block (&se->pre, set_descriptor);
|
||||
|
|
@ -5331,7 +5340,7 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr)
|
|||
/* A single scalar or derived type value. Create an array with all
|
||||
elements equal to that value. */
|
||||
gfc_init_se (&se, NULL);
|
||||
|
||||
|
||||
if (expr->expr_type == EXPR_CONSTANT)
|
||||
gfc_conv_constant (&se, expr);
|
||||
else
|
||||
|
|
@ -5743,7 +5752,7 @@ gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
|
|||
tmp = gfc_conv_expr_present (sym);
|
||||
stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
|
||||
}
|
||||
|
||||
|
||||
gfc_add_init_cleanup (block, stmt, NULL_TREE);
|
||||
}
|
||||
|
||||
|
|
@ -5945,7 +5954,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
|
|||
asprintf (&msg, "Dimension %d of array '%s' has extent "
|
||||
"%%ld instead of %%ld", n+1, sym->name);
|
||||
|
||||
gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
|
||||
gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
|
||||
fold_convert (long_integer_type_node, temp),
|
||||
fold_convert (long_integer_type_node, stride2));
|
||||
|
||||
|
|
@ -6069,7 +6078,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
|
|||
gfc_add_expr_to_block (&cleanup, tmp);
|
||||
|
||||
stmtCleanup = gfc_finish_block (&cleanup);
|
||||
|
||||
|
||||
/* Only do the cleanup if the array was repacked. */
|
||||
tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
|
||||
tmp = gfc_conv_descriptor_data_get (tmp);
|
||||
|
|
@ -6381,7 +6390,7 @@ walk_coarray (gfc_expr *e)
|
|||
EXPR is the right-hand side of a pointer assignment and
|
||||
se->expr is the descriptor for the previously-evaluated
|
||||
left-hand side. The function creates an assignment from
|
||||
EXPR to se->expr.
|
||||
EXPR to se->expr.
|
||||
|
||||
|
||||
The se->force_tmp flag disables the non-copying descriptor optimization
|
||||
|
|
@ -6495,7 +6504,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
|
|||
return;
|
||||
}
|
||||
break;
|
||||
|
||||
|
||||
case EXPR_FUNCTION:
|
||||
/* A transformational function return value will be a temporary
|
||||
array descriptor. We still need to go through the scalarizer
|
||||
|
|
@ -6785,7 +6794,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
|
|||
/* Vector subscripts need copying and are handled elsewhere. */
|
||||
if (info->ref)
|
||||
gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
|
||||
|
||||
|
||||
/* look for the corresponding scalarizer dimension: dim. */
|
||||
for (dim = 0; dim < ndim; dim++)
|
||||
if (ss->dim[dim] == n)
|
||||
|
|
@ -7011,9 +7020,9 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
|
|||
|
||||
if (!sym->attr.pointer
|
||||
&& sym->as
|
||||
&& sym->as->type != AS_ASSUMED_SHAPE
|
||||
&& sym->as->type != AS_ASSUMED_SHAPE
|
||||
&& sym->as->type != AS_DEFERRED
|
||||
&& sym->as->type != AS_ASSUMED_RANK
|
||||
&& sym->as->type != AS_ASSUMED_RANK
|
||||
&& !sym->attr.allocatable)
|
||||
{
|
||||
/* Some variables are declared directly, others are declared as
|
||||
|
|
@ -7071,7 +7080,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
|
|||
&& expr->symtree->n.sym->attr.allocatable;
|
||||
|
||||
/* Or ultimate allocatable components. */
|
||||
ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
|
||||
ultimate_alloc_comp = contiguous && ultimate_alloc_comp;
|
||||
|
||||
if (no_pack || array_constructor || good_allocatable || ultimate_alloc_comp)
|
||||
{
|
||||
|
|
@ -7254,7 +7263,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
|
|||
|
||||
tree
|
||||
gfc_trans_dealloc_allocated (tree descriptor, bool coarray)
|
||||
{
|
||||
{
|
||||
tree tmp;
|
||||
tree var;
|
||||
stmtblock_t block;
|
||||
|
|
@ -7454,7 +7463,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
|
|||
tmp = gfc_conv_array_data (decl);
|
||||
var = build_fold_indirect_ref_loc (input_location,
|
||||
tmp);
|
||||
|
||||
|
||||
/* Get the number of elements - 1 and set the counter. */
|
||||
if (GFC_DESCRIPTOR_TYPE_P (decl_type))
|
||||
{
|
||||
|
|
@ -7578,7 +7587,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
|
|||
/* Allocatable CLASS components. */
|
||||
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
|
||||
decl, cdecl, NULL_TREE);
|
||||
|
||||
|
||||
/* Add reference to '_data' component. */
|
||||
tmp = CLASS_DATA (c)->backend_decl;
|
||||
comp = fold_build3_loc (input_location, COMPONENT_REF,
|
||||
|
|
@ -7725,7 +7734,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
|
|||
|
||||
null_cond = fold_build2_loc (input_location, NE_EXPR,
|
||||
boolean_type_node, src_data,
|
||||
null_pointer_node);
|
||||
null_pointer_node);
|
||||
|
||||
gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond,
|
||||
tmp, null_data));
|
||||
|
|
@ -8030,7 +8039,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
|
|||
as = NULL;
|
||||
|
||||
/* If the lhs shape is not the same as the rhs jump to setting the
|
||||
bounds and doing the reallocation....... */
|
||||
bounds and doing the reallocation....... */
|
||||
for (n = 0; n < expr1->rank; n++)
|
||||
{
|
||||
/* Check the shape. */
|
||||
|
|
@ -8051,13 +8060,13 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
|
|||
tmp = build3_v (COND_EXPR, cond,
|
||||
build1_v (GOTO_EXPR, jump_label1),
|
||||
build_empty_stmt (input_location));
|
||||
gfc_add_expr_to_block (&fblock, tmp);
|
||||
gfc_add_expr_to_block (&fblock, tmp);
|
||||
}
|
||||
|
||||
/* ....else jump past the (re)alloc code. */
|
||||
tmp = build1_v (GOTO_EXPR, jump_label2);
|
||||
gfc_add_expr_to_block (&fblock, tmp);
|
||||
|
||||
|
||||
/* Add the label to start automatic (re)allocation. */
|
||||
tmp = build1_v (LABEL_EXPR, jump_label1);
|
||||
gfc_add_expr_to_block (&fblock, tmp);
|
||||
|
|
@ -8096,7 +8105,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
|
|||
unallocated allocatable variable, then it is allocated with each
|
||||
deferred type parameter equal to the corresponding type parameters
|
||||
of expr , with the shape of expr , and with each lower bound equal
|
||||
to the corresponding element of LBOUND(expr)."
|
||||
to the corresponding element of LBOUND(expr)."
|
||||
Reuse size1 to keep a dimension-by-dimension track of the
|
||||
stride of the new array. */
|
||||
size1 = gfc_index_one_node;
|
||||
|
|
@ -8340,7 +8349,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
|
|||
sym->backend_decl);
|
||||
type = TREE_TYPE (descriptor);
|
||||
}
|
||||
|
||||
|
||||
/* NULLIFY the data pointer. */
|
||||
if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
|
||||
gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);
|
||||
|
|
|
|||
|
|
@ -198,16 +198,31 @@ gfc_vtable_final_get (tree decl)
|
|||
#undef VTABLE_FINAL_FIELD
|
||||
|
||||
|
||||
/* Obtain the vptr of the last class reference in an expression. */
|
||||
/* Obtain the vptr of the last class reference in an expression.
|
||||
Return NULL_TREE if no class reference is found. */
|
||||
|
||||
tree
|
||||
gfc_get_vptr_from_expr (tree expr)
|
||||
{
|
||||
tree tmp = expr;
|
||||
while (tmp && !GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
|
||||
tmp = TREE_OPERAND (tmp, 0);
|
||||
tmp = gfc_class_vptr_get (tmp);
|
||||
return tmp;
|
||||
tree tmp;
|
||||
tree type;
|
||||
|
||||
for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
|
||||
{
|
||||
type = TREE_TYPE (tmp);
|
||||
while (type)
|
||||
{
|
||||
if (GFC_CLASS_TYPE_P (type))
|
||||
return gfc_class_vptr_get (tmp);
|
||||
if (type != TYPE_CANONICAL (type))
|
||||
type = TYPE_CANONICAL (type);
|
||||
else
|
||||
type = NULL_TREE;
|
||||
}
|
||||
if (TREE_CODE (tmp) == VAR_DECL)
|
||||
break;
|
||||
}
|
||||
return NULL_TREE;
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -594,7 +609,7 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
|
|||
}
|
||||
else
|
||||
{
|
||||
if (CLASS_DATA (e)->attr.codimension)
|
||||
if (TREE_TYPE (parmse->expr) != TREE_TYPE (ctree))
|
||||
parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
|
||||
TREE_TYPE (ctree), parmse->expr);
|
||||
gfc_add_modify (&block, ctree, parmse->expr);
|
||||
|
|
@ -1562,6 +1577,7 @@ gfc_conv_component_ref (gfc_se * se, gfc_ref * ref)
|
|||
c->norestrict_decl = f2;
|
||||
field = f2;
|
||||
}
|
||||
|
||||
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
|
||||
decl, field, NULL_TREE);
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
/* Backend support for Fortran 95 basic types and derived types.
|
||||
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
|
||||
2010, 2011, 2012
|
||||
2010, 2011, 2012, 2013
|
||||
Free Software Foundation, Inc.
|
||||
Contributed by Paul Brook <paul@nowt.org>
|
||||
and Steven Bosscher <s.bosscher@student.tudelft.nl>
|
||||
|
|
@ -124,7 +124,7 @@ int gfc_atomic_logical_kind;
|
|||
|
||||
/* The kind size used for record offsets. If the target system supports
|
||||
kind=8, this will be set to 8, otherwise it is set to 4. */
|
||||
int gfc_intio_kind;
|
||||
int gfc_intio_kind;
|
||||
|
||||
/* The integer kind used to store character lengths. */
|
||||
int gfc_charlen_int_kind;
|
||||
|
|
@ -138,7 +138,7 @@ gfc_try
|
|||
gfc_check_any_c_kind (gfc_typespec *ts)
|
||||
{
|
||||
int i;
|
||||
|
||||
|
||||
for (i = 0; i < ISOCBINDING_NUMBER; i++)
|
||||
{
|
||||
/* Check for any C interoperable kind for the given type/kind in ts.
|
||||
|
|
@ -400,7 +400,7 @@ gfc_init_kinds (void)
|
|||
i_index += 1;
|
||||
}
|
||||
|
||||
/* Set the kind used to match GFC_INT_IO in libgfortran. This is
|
||||
/* Set the kind used to match GFC_INT_IO in libgfortran. This is
|
||||
used for large file access. */
|
||||
|
||||
if (saw_i8)
|
||||
|
|
@ -408,8 +408,8 @@ gfc_init_kinds (void)
|
|||
else
|
||||
gfc_intio_kind = 4;
|
||||
|
||||
/* If we do not at least have kind = 4, everything is pointless. */
|
||||
gcc_assert(saw_i4);
|
||||
/* If we do not at least have kind = 4, everything is pointless. */
|
||||
gcc_assert(saw_i4);
|
||||
|
||||
/* Set the maximum integer kind. Used with at least BOZ constants. */
|
||||
gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind;
|
||||
|
|
@ -550,7 +550,7 @@ gfc_init_kinds (void)
|
|||
else
|
||||
gfc_default_real_kind = gfc_real_kinds[0].kind;
|
||||
|
||||
/* Choose the default double kind. If -fdefault-real and -fdefault-double
|
||||
/* Choose the default double kind. If -fdefault-real and -fdefault-double
|
||||
are specified, we use kind=8, if it's available. If -fdefault-real is
|
||||
specified without -fdefault-double, we use kind=16, if it's available.
|
||||
Otherwise we do not change anything. */
|
||||
|
|
@ -1624,10 +1624,10 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
|
|||
type = build_pointer_type (type);
|
||||
|
||||
if (restricted)
|
||||
type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
|
||||
type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
|
||||
|
||||
GFC_ARRAY_TYPE_P (type) = 1;
|
||||
TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
|
||||
TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type));
|
||||
}
|
||||
|
||||
return type;
|
||||
|
|
@ -2286,7 +2286,7 @@ gfc_copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to,
|
|||
a derived type, we need a copy of its component declarations.
|
||||
This is done by recursing into gfc_get_derived_type and
|
||||
ensures that the component's component declarations have
|
||||
been built. If it is a character, we need the character
|
||||
been built. If it is a character, we need the character
|
||||
length, as well. */
|
||||
for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
|
||||
{
|
||||
|
|
@ -2367,7 +2367,7 @@ gfc_get_derived_type (gfc_symbol * derived)
|
|||
BT_INTEGER that needs to fit a void * for the purpose of the
|
||||
iso_c_binding derived types. */
|
||||
derived->ts.f90_type = BT_VOID;
|
||||
|
||||
|
||||
return derived->backend_decl;
|
||||
}
|
||||
|
||||
|
|
@ -2532,6 +2532,15 @@ gfc_get_derived_type (gfc_symbol * derived)
|
|||
field_type = build_pointer_type_for_mode (TREE_TYPE (field_type),
|
||||
ptr_mode, true);
|
||||
|
||||
/* Ensure that the CLASS language specific flag is set. */
|
||||
if (c->ts.type == BT_CLASS)
|
||||
{
|
||||
if (POINTER_TYPE_P (field_type))
|
||||
GFC_CLASS_TYPE_P (TREE_TYPE (field_type)) = 1;
|
||||
else
|
||||
GFC_CLASS_TYPE_P (field_type) = 1;
|
||||
}
|
||||
|
||||
field = gfc_add_field_to_struct (typenode,
|
||||
get_identifier (c->name),
|
||||
field_type, &chain);
|
||||
|
|
@ -2832,7 +2841,7 @@ gfc_get_function_type (gfc_symbol * sym)
|
|||
&& sym->ts.kind == gfc_default_real_kind
|
||||
&& !sym->attr.always_explicit)
|
||||
{
|
||||
/* Special case: f2c calling conventions require that (scalar)
|
||||
/* Special case: f2c calling conventions require that (scalar)
|
||||
default REAL functions return the C type double instead. f2c
|
||||
compatibility is only an issue with functions that don't
|
||||
require an explicit interface, as only these could be
|
||||
|
|
|
|||
|
|
@ -1,3 +1,10 @@
|
|||
2013-01-06 Paul Thomas <pault@gcc.gnu.org>
|
||||
|
||||
PR fortran/PR53876
|
||||
PR fortran/PR54990
|
||||
PR fortran/PR54992
|
||||
* gfortran.dg/class_array_15.f03: New test.
|
||||
|
||||
2013-01-06 Mikael Morin <mikael@gcc.gnu.org>
|
||||
|
||||
PR fortran/42769
|
||||
|
|
|
|||
116
gcc/testsuite/gfortran.dg/class_array_15.f03
Normal file
116
gcc/testsuite/gfortran.dg/class_array_15.f03
Normal file
|
|
@ -0,0 +1,116 @@
|
|||
! { dg-do run }
|
||||
!
|
||||
! Tests the fixes for three bugs with the same underlying cause. All are regressions
|
||||
! that come about because class array elements end up with a different tree type
|
||||
! to the class array. In addition, the language specific flag that marks a class
|
||||
! container is not being set.
|
||||
!
|
||||
! PR53876 contributed by Prince Ogunbade <pogos77@hotmail.com>
|
||||
! PR54990 contributed by Janus Weil <janus@gcc.gnu.org>
|
||||
! PR54992 contributed by Tobias Burnus <burnus@gcc.gnu.org>
|
||||
! The two latter bugs were reported by Andrew Benson
|
||||
! starting at http://gcc.gnu.org/ml/fortran/2012-10/msg00087.html
|
||||
!
|
||||
module G_Nodes
|
||||
type :: nc
|
||||
type(tn), pointer :: hostNode
|
||||
end type nc
|
||||
type, extends(nc) :: ncBh
|
||||
end type ncBh
|
||||
type, public, extends(ncBh) :: ncBhStd
|
||||
double precision :: massSeedData
|
||||
end type ncBhStd
|
||||
type, public :: tn
|
||||
class (ncBh), allocatable, dimension(:) :: cBh
|
||||
end type tn
|
||||
type(ncBhStd) :: defaultBhC
|
||||
contains
|
||||
subroutine Node_C_Bh_Move(targetNode)
|
||||
implicit none
|
||||
type (tn ), intent(inout) , target :: targetNode
|
||||
class(ncBh), allocatable , dimension(:) :: instancesTemporary
|
||||
! These two lines resulted in the wrong result:
|
||||
allocate(instancesTemporary(2),source=defaultBhC)
|
||||
call Move_Alloc(instancesTemporary,targetNode%cBh)
|
||||
! These two lines gave the correct result:
|
||||
!!deallocate(targetNode%cBh)
|
||||
!!allocate(targetNode%cBh(2))
|
||||
targetNode%cBh(1)%hostNode => targetNode
|
||||
targetNode%cBh(2)%hostNode => targetNode
|
||||
return
|
||||
end subroutine Node_C_Bh_Move
|
||||
function bhGet(self,instance)
|
||||
implicit none
|
||||
class (ncBh), pointer :: bhGet
|
||||
class (tn ), intent(inout), target :: self
|
||||
integer , intent(in ) :: instance
|
||||
bhGet => self%cBh(instance)
|
||||
return
|
||||
end function bhGet
|
||||
end module G_Nodes
|
||||
|
||||
call pr53876
|
||||
call pr54990
|
||||
call pr54992
|
||||
end
|
||||
|
||||
subroutine pr53876
|
||||
IMPLICIT NONE
|
||||
TYPE :: individual
|
||||
integer :: icomp ! Add an extra component to test offset
|
||||
REAL, DIMENSION(:), ALLOCATABLE :: genes
|
||||
END TYPE
|
||||
CLASS(individual), DIMENSION(:), ALLOCATABLE :: indv
|
||||
allocate (indv(2), source = [individual(1, [99,999]), &
|
||||
individual(2, [999,9999])])
|
||||
CALL display_indv(indv(2)) ! Similarly, reference 2nd element to test offset
|
||||
CONTAINS
|
||||
SUBROUTINE display_indv(self)
|
||||
CLASS(individual), INTENT(IN) :: self
|
||||
if (any(self%genes .ne. [999,9999]) )call abort
|
||||
END SUBROUTINE
|
||||
END
|
||||
|
||||
subroutine pr54990
|
||||
implicit none
|
||||
type :: ncBhStd
|
||||
integer :: i
|
||||
end type
|
||||
type, extends(ncBhStd) :: ncBhStde
|
||||
integer :: i2(2)
|
||||
end type
|
||||
type :: tn
|
||||
integer :: i ! Add an extra component to test offset
|
||||
class (ncBhStd), allocatable, dimension(:) :: cBh
|
||||
end type
|
||||
integer :: i
|
||||
type(tn), target :: a
|
||||
allocate (a%cBh(2), source = [(ncBhStde(i*99, [1,2]), i = 1,2)])
|
||||
select type (q => a%cBh(2)) ! Similarly, reference 2nd element to test offset
|
||||
type is (ncBhStd)
|
||||
call abort
|
||||
type is (ncBhStde)
|
||||
if (q%i .ne. 198) call abort ! This tests that the component really gets the
|
||||
end select ! language specific flag denoting a class type
|
||||
end
|
||||
|
||||
subroutine pr54992 ! This test remains as the original.
|
||||
use G_Nodes
|
||||
implicit none
|
||||
type (tn), target :: b
|
||||
class(ncBh), pointer :: bh
|
||||
class(ncBh), allocatable, dimension(:) :: t
|
||||
allocate(b%cBh(1),source=defaultBhC)
|
||||
b%cBh(1)%hostNode => b
|
||||
! #1 this worked
|
||||
if (loc(b) .ne. loc(b%cBh(1)%hostNode)) call abort
|
||||
call Node_C_Bh_Move(b)
|
||||
! #2 this worked
|
||||
if (loc(b) .ne. loc(b%cBh(1)%hostNode)) call abort
|
||||
if (loc(b) .ne. loc(b%cBh(2)%hostNode)) call abort
|
||||
! #3 this did not
|
||||
bh => bhGet(b,instance=1)
|
||||
if (loc (b) .ne. loc(bh%hostNode)) call abort
|
||||
bh => bhGet(b,instance=2)
|
||||
if (loc (b) .ne. loc(bh%hostNode)) call abort
|
||||
end
|
||||
Loading…
Add table
Reference in a new issue