git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

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 2013-01-06 21:32:48 +00:00
parent 1ab05c31a0
commit f04986a90b
6 changed files with 247 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
gcc/fortran/ChangeLog
View File

@ -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> 2013-01-06 Mikael Morin <mikael@gcc.gnu.org>
PR fortran/42769 PR fortran/42769

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

@ -1,6 +1,6 @@
/* Array translation routines /* Array translation routines
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
2011, 2012 2011, 2012, 2013
Free Software Foundation, Inc. Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org> Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl> 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. /* This provides WRITE access to the data field.
TUPLES_P is true if we are generating tuples. TUPLES_P is true if we are generating tuples.
This function gets called through the following macros: This function gets called through the following macros:
gfc_conv_descriptor_data_set gfc_conv_descriptor_data_set
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; return ss;
} }
/* Creates and initializes a scalar type gfc_ss struct. */ /* 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. */ /* Variables needed for bounds-checking. */
static bool first_len; static bool first_len;
static tree first_len_val; static tree first_len_val;
static bool typespec_chararray_ctor; static bool typespec_chararray_ctor;
static void static void
@ -2206,7 +2206,7 @@ trans_array_constructor (gfc_ss * ss, locus * where)
if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
&& expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor) && expr->ts.type == BT_CHARACTER && !typespec_chararray_ctor)
{ {
first_len_val = gfc_create_var (gfc_charlen_type_node, "len"); first_len_val = gfc_create_var (gfc_charlen_type_node, "len");
first_len = true; first_len = true;
} }
@ -2217,7 +2217,7 @@ trans_array_constructor (gfc_ss * ss, locus * where)
if (expr->ts.type == BT_CHARACTER) if (expr->ts.type == BT_CHARACTER)
{ {
bool const_string; bool const_string;
/* get_array_ctor_strlen walks the elements of the constructor, if a /* 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 typespec was given, we already know the string length and want the one
specified there. */ specified there. */
@ -2924,9 +2924,9 @@ conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
gcc_assert (se->loop); gcc_assert (se->loop);
index = se->loop->loopvar[se->loop->order[i]]; 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 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 if (se->ss && se->ss->info->type == GFC_SS_FUNCTION
&& se->ss->info->expr && se->ss->info->expr
&& se->ss->info->expr->symtree && 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; ts = &ref->u.c.component->ts;
class_ref = ref; class_ref = ref;
break; break;
} }
} }
if (ts == NULL) if (ts == NULL)
@ -3099,31 +3099,40 @@ static tree
build_array_ref (tree desc, tree offset, tree decl) build_array_ref (tree desc, tree offset, tree decl)
{ {
tree tmp; 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 /* Class array references need special treatment because the assigned
type size needs to be used to point to the element. */ type size needs to be used to point to the element. */
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)) if (type && GFC_CLASS_TYPE_P (type))
&& TREE_CODE (desc) == COMPONENT_REF
&& GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0))))
{ {
tree type = gfc_get_element_type (TREE_TYPE (desc)); type = gfc_get_element_type (TREE_TYPE (desc));
tmp = TREE_OPERAND (desc, 0); tmp = TREE_OPERAND (desc, 0);
tmp = gfc_get_class_array_ref (offset, tmp); tmp = gfc_get_class_array_ref (offset, tmp);
tmp = fold_convert (build_pointer_type (type), tmp); tmp = fold_convert (build_pointer_type (type), tmp);
tmp = build_fold_indirect_ref_loc (input_location, tmp); tmp = build_fold_indirect_ref_loc (input_location, tmp);
} return 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);
} }
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; return tmp;
} }
/* Build an array reference. se->expr already holds the array descriptor. /* Build an array reference. se->expr already holds the array descriptor.
This should be either a variable, indirect variable reference or component This should be either a variable, indirect variable reference or component
reference. For arrays which do not have a descriptor, se->expr will be 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; 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); indexse.expr, tmp);
asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' " asprintf (&msg, "Index '%%ld' of dimension %d of array '%s' "
"below lower bound of %%ld", n+1, sym->name); "below lower bound of %%ld", n+1, sym->name);
@ -3964,8 +3973,8 @@ done:
stride_pos, stride_neg); stride_pos, stride_neg);
/* Check the start of the range against the lower and upper /* Check the start of the range against the lower and upper
bounds of the array, if the range is not empty. bounds of the array, if the range is not empty.
If upper bound is present, include both bounds in the If upper bound is present, include both bounds in the
error message. */ error message. */
if (check_upper) if (check_upper)
{ {
@ -4012,7 +4021,7 @@ done:
fold_convert (long_integer_type_node, lbound)); fold_convert (long_integer_type_node, lbound));
free (msg); free (msg);
} }
/* Compute the last element of the range, which is not /* Compute the last element of the range, which is not
necessarily "end" (think 0:5:3, which doesn't contain 5) necessarily "end" (think 0:5:3, which doesn't contain 5)
and check it against both lower and upper bounds. */ and check it against both lower and upper bounds. */
@ -4041,12 +4050,12 @@ done:
gfc_trans_runtime_check (true, false, tmp2, &inner, gfc_trans_runtime_check (true, false, tmp2, &inner,
expr_loc, msg, expr_loc, msg,
fold_convert (long_integer_type_node, tmp), 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)); fold_convert (long_integer_type_node, lbound));
gfc_trans_runtime_check (true, false, tmp3, &inner, gfc_trans_runtime_check (true, false, tmp3, &inner,
expr_loc, msg, expr_loc, msg,
fold_convert (long_integer_type_node, tmp), 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)); fold_convert (long_integer_type_node, lbound));
free (msg); free (msg);
} }
@ -4885,7 +4894,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
ubound = lower[n]; 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); gfc_rank_cst[n], se.expr);
conv_lbound = 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 /* Check whether multiplying the stride by the number of
elements in this dimension would overflow. We must also check elements in this dimension would overflow. We must also check
whether the current dimension has zero size in order to avoid 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, tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
gfc_array_index_type, gfc_array_index_type,
fold_convert (gfc_array_index_type, fold_convert (gfc_array_index_type,
TYPE_MAX_VALUE (gfc_array_index_type)), TYPE_MAX_VALUE (gfc_array_index_type)),
size); size);
cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR, 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, tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
*overflow, tmp); *overflow, tmp);
*overflow = gfc_evaluate_now (tmp, pblock); *overflow = gfc_evaluate_now (tmp, pblock);
/* Multiply the stride by the number of elements in this dimension. */ /* Multiply the stride by the number of elements in this dimension. */
stride = fold_build2_loc (input_location, MULT_EXPR, stride = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type, stride, size); 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]; 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); gfc_rank_cst[n], se.expr);
if (n < rank + corank - 1) 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 /* First check for overflow. Since an array of type character can
have zero element_size, we must check for that before have zero element_size, we must check for that before
dividing. */ dividing. */
tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
size_type_node, size_type_node,
TYPE_MAX_VALUE (size_type_node), element_size); TYPE_MAX_VALUE (size_type_node), element_size);
cond = gfc_unlikely (fold_build2_loc (input_location, LT_EXPR, 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, cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
boolean_type_node, var_overflow, integer_zero_node)); 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)); error, gfc_finish_block (&elseblock));
} }
else else
@ -5221,7 +5230,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
if (expr->ts.type == BT_CLASS) if (expr->ts.type == BT_CLASS)
{ {
tmp = build_int_cst (unsigned_char_type_node, 0); 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 memory because we cannot know if dynamic types have allocatable
components or not. */ components or not. */
tmp = build_call_expr_loc (input_location, 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. */ /* Update the array descriptors. */
if (dimension) if (dimension)
gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset); gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
set_descriptor = gfc_finish_block (&set_descriptor_block); set_descriptor = gfc_finish_block (&set_descriptor_block);
if (status != NULL_TREE) 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, gfc_add_expr_to_block (&se->pre,
fold_build3_loc (input_location, COND_EXPR, void_type_node, fold_build3_loc (input_location, COND_EXPR, void_type_node,
gfc_likely (cond), set_descriptor, gfc_likely (cond), set_descriptor,
build_empty_stmt (input_location))); build_empty_stmt (input_location)));
} }
else else
gfc_add_expr_to_block (&se->pre, set_descriptor); 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 /* A single scalar or derived type value. Create an array with all
elements equal to that value. */ elements equal to that value. */
gfc_init_se (&se, NULL); gfc_init_se (&se, NULL);
if (expr->expr_type == EXPR_CONSTANT) if (expr->expr_type == EXPR_CONSTANT)
gfc_conv_constant (&se, expr); gfc_conv_constant (&se, expr);
else else
@ -5743,7 +5752,7 @@ gfc_trans_g77_array (gfc_symbol * sym, gfc_wrapped_block * block)
tmp = gfc_conv_expr_present (sym); tmp = gfc_conv_expr_present (sym);
stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location)); stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt (input_location));
} }
gfc_add_init_cleanup (block, stmt, NULL_TREE); 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 " asprintf (&msg, "Dimension %d of array '%s' has extent "
"%%ld instead of %%ld", n+1, sym->name); "%%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, temp),
fold_convert (long_integer_type_node, stride2)); 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); gfc_add_expr_to_block (&cleanup, tmp);
stmtCleanup = gfc_finish_block (&cleanup); stmtCleanup = gfc_finish_block (&cleanup);
/* Only do the cleanup if the array was repacked. */ /* Only do the cleanup if the array was repacked. */
tmp = build_fold_indirect_ref_loc (input_location, dumdesc); tmp = build_fold_indirect_ref_loc (input_location, dumdesc);
tmp = gfc_conv_descriptor_data_get (tmp); 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 EXPR is the right-hand side of a pointer assignment and
se->expr is the descriptor for the previously-evaluated se->expr is the descriptor for the previously-evaluated
left-hand side. The function creates an assignment from 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 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; return;
} }
break; break;
case EXPR_FUNCTION: case EXPR_FUNCTION:
/* A transformational function return value will be a temporary /* A transformational function return value will be a temporary
array descriptor. We still need to go through the scalarizer 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. */ /* Vector subscripts need copying and are handled elsewhere. */
if (info->ref) if (info->ref)
gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE); gcc_assert (info->ref->u.ar.dimen_type[n] == DIMEN_RANGE);
/* look for the corresponding scalarizer dimension: dim. */ /* look for the corresponding scalarizer dimension: dim. */
for (dim = 0; dim < ndim; dim++) for (dim = 0; dim < ndim; dim++)
if (ss->dim[dim] == n) 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 if (!sym->attr.pointer
&& sym->as && sym->as
&& sym->as->type != AS_ASSUMED_SHAPE && sym->as->type != AS_ASSUMED_SHAPE
&& sym->as->type != AS_DEFERRED && sym->as->type != AS_DEFERRED
&& sym->as->type != AS_ASSUMED_RANK && sym->as->type != AS_ASSUMED_RANK
&& !sym->attr.allocatable) && !sym->attr.allocatable)
{ {
/* Some variables are declared directly, others are declared as /* 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; && expr->symtree->n.sym->attr.allocatable;
/* Or ultimate allocatable components. */ /* 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) 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 tree
gfc_trans_dealloc_allocated (tree descriptor, bool coarray) gfc_trans_dealloc_allocated (tree descriptor, bool coarray)
{ {
tree tmp; tree tmp;
tree var; tree var;
stmtblock_t block; stmtblock_t block;
@ -7454,7 +7463,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
tmp = gfc_conv_array_data (decl); tmp = gfc_conv_array_data (decl);
var = build_fold_indirect_ref_loc (input_location, var = build_fold_indirect_ref_loc (input_location,
tmp); tmp);
/* Get the number of elements - 1 and set the counter. */ /* Get the number of elements - 1 and set the counter. */
if (GFC_DESCRIPTOR_TYPE_P (decl_type)) if (GFC_DESCRIPTOR_TYPE_P (decl_type))
{ {
@ -7578,7 +7587,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
/* Allocatable CLASS components. */ /* Allocatable CLASS components. */
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE); decl, cdecl, NULL_TREE);
/* Add reference to '_data' component. */ /* Add reference to '_data' component. */
tmp = CLASS_DATA (c)->backend_decl; tmp = CLASS_DATA (c)->backend_decl;
comp = fold_build3_loc (input_location, COMPONENT_REF, 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, null_cond = fold_build2_loc (input_location, NE_EXPR,
boolean_type_node, src_data, boolean_type_node, src_data,
null_pointer_node); null_pointer_node);
gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond, gfc_add_expr_to_block (&fnblock, build3_v (COND_EXPR, null_cond,
tmp, null_data)); tmp, null_data));
@ -8030,7 +8039,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
as = NULL; as = NULL;
/* If the lhs shape is not the same as the rhs jump to setting the /* 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++) for (n = 0; n < expr1->rank; n++)
{ {
/* Check the shape. */ /* Check the shape. */
@ -8051,13 +8060,13 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
tmp = build3_v (COND_EXPR, cond, tmp = build3_v (COND_EXPR, cond,
build1_v (GOTO_EXPR, jump_label1), build1_v (GOTO_EXPR, jump_label1),
build_empty_stmt (input_location)); 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. */ /* ....else jump past the (re)alloc code. */
tmp = build1_v (GOTO_EXPR, jump_label2); tmp = build1_v (GOTO_EXPR, jump_label2);
gfc_add_expr_to_block (&fblock, tmp); gfc_add_expr_to_block (&fblock, tmp);
/* Add the label to start automatic (re)allocation. */ /* Add the label to start automatic (re)allocation. */
tmp = build1_v (LABEL_EXPR, jump_label1); tmp = build1_v (LABEL_EXPR, jump_label1);
gfc_add_expr_to_block (&fblock, tmp); 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 unallocated allocatable variable, then it is allocated with each
deferred type parameter equal to the corresponding type parameters deferred type parameter equal to the corresponding type parameters
of expr , with the shape of expr , and with each lower bound equal 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 Reuse size1 to keep a dimension-by-dimension track of the
stride of the new array. */ stride of the new array. */
size1 = gfc_index_one_node; size1 = gfc_index_one_node;
@ -8340,7 +8349,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
sym->backend_decl); sym->backend_decl);
type = TREE_TYPE (descriptor); type = TREE_TYPE (descriptor);
} }
/* NULLIFY the data pointer. */ /* NULLIFY the data pointer. */
if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save) if (GFC_DESCRIPTOR_TYPE_P (type) && !sym->attr.save)
gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node); gfc_conv_descriptor_data_set (&init, descriptor, null_pointer_node);

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

@ -198,16 +198,31 @@ gfc_vtable_final_get (tree decl)
#undef VTABLE_FINAL_FIELD #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 tree
gfc_get_vptr_from_expr (tree expr) gfc_get_vptr_from_expr (tree expr)
{ {
tree tmp = expr; tree tmp;
while (tmp && !GFC_CLASS_TYPE_P (TREE_TYPE (tmp))) tree type;
tmp = TREE_OPERAND (tmp, 0);
tmp = gfc_class_vptr_get (tmp); for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
return tmp; {
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 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, parmse->expr = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
TREE_TYPE (ctree), parmse->expr); TREE_TYPE (ctree), parmse->expr);
gfc_add_modify (&block, 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; c->norestrict_decl = f2;
field = f2; field = f2;
} }
tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field), tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
decl, field, NULL_TREE); decl, field, NULL_TREE);

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

@ -1,6 +1,6 @@
/* Backend support for Fortran 95 basic types and derived types. /* Backend support for Fortran 95 basic types and derived types.
Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
2010, 2011, 2012 2010, 2011, 2012, 2013
Free Software Foundation, Inc. Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org> Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl> 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 /* 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. */ 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. */ /* The integer kind used to store character lengths. */
int gfc_charlen_int_kind; int gfc_charlen_int_kind;
@ -138,7 +138,7 @@ gfc_try
gfc_check_any_c_kind (gfc_typespec *ts) gfc_check_any_c_kind (gfc_typespec *ts)
{ {
int i; int i;
for (i = 0; i < ISOCBINDING_NUMBER; i++) for (i = 0; i < ISOCBINDING_NUMBER; i++)
{ {
/* Check for any C interoperable kind for the given type/kind in ts. /* Check for any C interoperable kind for the given type/kind in ts.
@ -400,7 +400,7 @@ gfc_init_kinds (void)
i_index += 1; 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. */ used for large file access. */
if (saw_i8) if (saw_i8)
@ -408,8 +408,8 @@ gfc_init_kinds (void)
else else
gfc_intio_kind = 4; gfc_intio_kind = 4;
/* If we do not at least have kind = 4, everything is pointless. */ /* If we do not at least have kind = 4, everything is pointless. */
gcc_assert(saw_i4); gcc_assert(saw_i4);
/* Set the maximum integer kind. Used with at least BOZ constants. */ /* Set the maximum integer kind. Used with at least BOZ constants. */
gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind; gfc_max_integer_kind = gfc_integer_kinds[i_index - 1].kind;
@ -550,7 +550,7 @@ gfc_init_kinds (void)
else else
gfc_default_real_kind = gfc_real_kinds[0].kind; 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 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. specified without -fdefault-double, we use kind=16, if it's available.
Otherwise we do not change anything. */ 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); type = build_pointer_type (type);
if (restricted) if (restricted)
type = build_qualified_type (type, TYPE_QUAL_RESTRICT); type = build_qualified_type (type, TYPE_QUAL_RESTRICT);
GFC_ARRAY_TYPE_P (type) = 1; 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; 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. a derived type, we need a copy of its component declarations.
This is done by recursing into gfc_get_derived_type and This is done by recursing into gfc_get_derived_type and
ensures that the component's component declarations have 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. */ length, as well. */
for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next) 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 BT_INTEGER that needs to fit a void * for the purpose of the
iso_c_binding derived types. */ iso_c_binding derived types. */
derived->ts.f90_type = BT_VOID; derived->ts.f90_type = BT_VOID;
return derived->backend_decl; 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), field_type = build_pointer_type_for_mode (TREE_TYPE (field_type),
ptr_mode, true); 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, field = gfc_add_field_to_struct (typenode,
get_identifier (c->name), get_identifier (c->name),
field_type, &chain); field_type, &chain);
@ -2832,7 +2841,7 @@ gfc_get_function_type (gfc_symbol * sym)
&& sym->ts.kind == gfc_default_real_kind && sym->ts.kind == gfc_default_real_kind
&& !sym->attr.always_explicit) && !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 default REAL functions return the C type double instead. f2c
compatibility is only an issue with functions that don't compatibility is only an issue with functions that don't
require an explicit interface, as only these could be require an explicit interface, as only these could be

7
gcc/testsuite/ChangeLog
View File

@ -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> 2013-01-06 Mikael Morin <mikael@gcc.gnu.org>
PR fortran/42769 PR fortran/42769

116
gcc/testsuite/gfortran.dg/class_array_15.f03 Normal file
View 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