diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index f08f9b4c547..8c2cb3cc4b1 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,16 @@ +2013-01-06 Paul Thomas + + 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 PR fortran/42769 diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 06898920369..794322ac79a 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -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 and Steven Bosscher @@ -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); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 01d3595ae65..9452e276962 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 8394bf93576..cd9bde614c1 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -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 and Steven Bosscher @@ -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 diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 2e5c99ddec4..0f15221d3c5 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2013-01-06 Paul Thomas + + PR fortran/PR53876 + PR fortran/PR54990 + PR fortran/PR54992 + * gfortran.dg/class_array_15.f03: New test. + 2013-01-06 Mikael Morin PR fortran/42769 diff --git a/gcc/testsuite/gfortran.dg/class_array_15.f03 b/gcc/testsuite/gfortran.dg/class_array_15.f03 new file mode 100644 index 00000000000..7d1d4d7181b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/class_array_15.f03 @@ -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 +! PR54990 contributed by Janus Weil +! PR54992 contributed by Tobias Burnus +! 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