/* Make sure there is a vtable and, in particular, a _copy for the
rhs type. */
- if (UNLIMITED_POLY (lhs) && lhs->rank && rhs->ts.type != BT_CLASS)
+ if (lhs->ts.type == BT_CLASS && rhs->ts.type != BT_CLASS)
gfc_find_vtab (&rhs->ts);
bool caf_convert_to_send = flag_coarray == GFC_FCOARRAY_LIB
gcc_assert (TREE_CODE (tmp) == POINTER_TYPE);
tmp = TREE_TYPE (tmp); /* The descriptor itself. */
tmp = gfc_get_element_type (tmp);
- gcc_assert (tmp == gfc_get_element_type (TREE_TYPE (desc)));
packed = gfc_create_var (build_pointer_type (tmp), "data");
tmp = build_call_expr_loc (input_location,
}
+/* Use the information in the ss to obtain the required information about
+ the type and size of an array temporary, when the lhs in an assignment
+ is a class expression. */
+
+static tree
+get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype)
+{
+ gfc_ss *lhs_ss;
+ gfc_ss *rhs_ss;
+ tree tmp;
+ tree tmp2;
+ tree vptr;
+ tree rhs_class_expr = NULL_TREE;
+ tree lhs_class_expr = NULL_TREE;
+ bool unlimited_rhs = false;
+ bool unlimited_lhs = false;
+ bool rhs_function = false;
+ gfc_symbol *vtab;
+
+ /* The second element in the loop chain contains the source for the
+ temporary; ie. the rhs of the assignment. */
+ rhs_ss = ss->loop->ss->loop_chain;
+
+ if (rhs_ss != gfc_ss_terminator
+ && rhs_ss->info
+ && rhs_ss->info->expr
+ && rhs_ss->info->expr->ts.type == BT_CLASS
+ && rhs_ss->info->data.array.descriptor)
+ {
+ rhs_class_expr
+ = gfc_get_class_from_expr (rhs_ss->info->data.array.descriptor);
+ unlimited_rhs = UNLIMITED_POLY (rhs_ss->info->expr);
+ if (rhs_ss->info->expr->expr_type == EXPR_FUNCTION)
+ rhs_function = true;
+ }
+
+ /* For an assignment the lhs is the next element in the loop chain.
+ If we have a class rhs, this had better be a class variable
+ expression! */
+ lhs_ss = rhs_ss->loop_chain;
+ if (lhs_ss != gfc_ss_terminator
+ && lhs_ss->info
+ && lhs_ss->info->expr
+ && lhs_ss->info->expr->expr_type ==EXPR_VARIABLE
+ && lhs_ss->info->expr->ts.type == BT_CLASS)
+ {
+ tmp = lhs_ss->info->data.array.descriptor;
+ unlimited_lhs = UNLIMITED_POLY (rhs_ss->info->expr);
+ }
+ else
+ tmp = NULL_TREE;
+
+ /* Get the lhs class expression. */
+ if (tmp != NULL_TREE && lhs_ss->loop_chain == gfc_ss_terminator)
+ lhs_class_expr = gfc_get_class_from_expr (tmp);
+ else
+ return rhs_class_expr;
+
+ gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (lhs_class_expr)));
+
+ /* Set the lhs vptr and, if necessary, the _len field. */
+ if (rhs_class_expr)
+ {
+ /* Both lhs and rhs are class expressions. */
+ tmp = gfc_class_vptr_get (lhs_class_expr);
+ gfc_add_modify (pre, tmp,
+ fold_convert (TREE_TYPE (tmp),
+ gfc_class_vptr_get (rhs_class_expr)));
+ if (unlimited_lhs)
+ {
+ tmp = gfc_class_len_get (lhs_class_expr);
+ if (unlimited_rhs)
+ tmp2 = gfc_class_len_get (rhs_class_expr);
+ else
+ tmp2 = build_int_cst (TREE_TYPE (tmp), 0);
+ gfc_add_modify (pre, tmp, tmp2);
+ }
+
+ if (rhs_function)
+ {
+ tmp = gfc_class_data_get (rhs_class_expr);
+ gfc_conv_descriptor_offset_set (pre, tmp, gfc_index_zero_node);
+ }
+ }
+ else
+ {
+ /* lhs is class and rhs is intrinsic or derived type. */
+ *eltype = TREE_TYPE (rhs_ss->info->data.array.descriptor);
+ *eltype = gfc_get_element_type (*eltype);
+ vtab = gfc_find_vtab (&rhs_ss->info->expr->ts);
+ vptr = vtab->backend_decl;
+ if (vptr == NULL_TREE)
+ vptr = gfc_get_symbol_decl (vtab);
+ vptr = gfc_build_addr_expr (NULL_TREE, vptr);
+ tmp = gfc_class_vptr_get (lhs_class_expr);
+ gfc_add_modify (pre, tmp,
+ fold_convert (TREE_TYPE (tmp), vptr));
+
+ if (unlimited_lhs)
+ {
+ tmp = gfc_class_len_get (lhs_class_expr);
+ if (rhs_ss->info
+ && rhs_ss->info->expr
+ && rhs_ss->info->expr->ts.type == BT_CHARACTER)
+ tmp2 = build_int_cst (TREE_TYPE (tmp),
+ rhs_ss->info->expr->ts.kind);
+ else
+ tmp2 = build_int_cst (TREE_TYPE (tmp), 0);
+ gfc_add_modify (pre, tmp, tmp2);
+ }
+ }
+
+ return rhs_class_expr;
+}
+
+
+
/* Generate code to create and initialize the descriptor for a temporary
array. This is used for both temporaries needed by the scalarizer, and
functions returning arrays. Adjusts the loop variables to be
{
gcc_assert (POINTER_TYPE_P (TREE_TYPE (initial)));
class_expr = build_fold_indirect_ref_loc (input_location, initial);
- eltype = TREE_TYPE (class_expr);
- eltype = gfc_get_element_type (eltype);
/* Obtain the structure (class) expression. */
- class_expr = TREE_OPERAND (class_expr, 0);
+ class_expr = gfc_get_class_from_expr (class_expr);
gcc_assert (class_expr);
}
+ /* Otherwise, some expressions, such as class functions, arising from
+ dependency checking in assignments come here with class element type.
+ The descriptor can be obtained from the ss->info and then converted
+ to the class object. */
+ if (class_expr == NULL_TREE && GFC_CLASS_TYPE_P (eltype))
+ class_expr = get_class_info_from_ss (pre, ss, &eltype);
+
+ /* If the dynamic type is not available, use the declared type. */
+ if (eltype && GFC_CLASS_TYPE_P (eltype))
+ eltype = gfc_get_element_type (TREE_TYPE (TYPE_FIELDS (eltype)));
+
+ if (class_expr == NULL_TREE)
+ elemsize = fold_convert (gfc_array_index_type,
+ TYPE_SIZE_UNIT (eltype));
+ else
+ {
+ /* Unlimited polymorphic entities are initialised with NULL vptr. They
+ can be tested for by checking if the len field is present. If so
+ test the vptr before using the vtable size. */
+ tmp = gfc_class_vptr_get (class_expr);
+ tmp = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node,
+ tmp, build_int_cst (TREE_TYPE (tmp), 0));
+ elemsize = fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type,
+ tmp,
+ gfc_class_vtab_size_get (class_expr),
+ gfc_index_zero_node);
+ elemsize = gfc_evaluate_now (elemsize, pre);
+ elemsize = gfc_resize_class_size_with_len (pre, class_expr, elemsize);
+ /* Casting the data as a character of the dynamic length ensures that
+ assignment of elements works when needed. */
+ eltype = gfc_get_character_type_len (1, elemsize);
+ }
+
memset (from, 0, sizeof (from));
memset (to, 0, sizeof (to));
}
}
- if (class_expr == NULL_TREE)
- elemsize = fold_convert (gfc_array_index_type,
- TYPE_SIZE_UNIT (gfc_get_element_type (type)));
- else
- elemsize = gfc_class_vtab_size_get (class_expr);
-
/* Get the size of the array. */
if (size && !callee_alloc)
{
}
/* Also the data pointer. */
tmp = gfc_conv_array_data (se.expr);
- /* If this is a variable or address of a variable we use it directly.
+ /* If this is a variable or address or a class array, use it directly.
Otherwise we must evaluate it now to avoid breaking dependency
analysis by pulling the expressions for elemental array indices
inside the loop. */
if (!(DECL_P (tmp)
|| (TREE_CODE (tmp) == ADDR_EXPR
- && DECL_P (TREE_OPERAND (tmp, 0)))))
+ && DECL_P (TREE_OPERAND (tmp, 0)))
+ || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))
+ && TREE_CODE (se.expr) == COMPONENT_REF
+ && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (se.expr, 0))))))
tmp = gfc_evaluate_now (tmp, block);
info->data = tmp;
size = gfc_class_vtab_size_get (decl);
/* For unlimited polymorphic entities then _len component needs to be
- multiplied with the size. If no _len component is present, then
- gfc_class_len_or_zero_get () return a zero_node. */
- tmp = gfc_class_len_or_zero_get (decl);
- if (!integer_zerop (tmp))
- size = fold_build2 (MULT_EXPR, TREE_TYPE (index),
- fold_convert (TREE_TYPE (index), size),
- fold_build2 (MAX_EXPR, TREE_TYPE (index),
- fold_convert (TREE_TYPE (index), tmp),
- fold_convert (TREE_TYPE (index),
- integer_one_node)));
- else
- size = fold_convert (TREE_TYPE (index), size);
+ multiplied with the size. */
+ size = gfc_resize_class_size_with_len (&se->pre, decl, size);
+
+ size = fold_convert (TREE_TYPE (index), size);
/* Build the address of the element. */
type = TREE_TYPE (TREE_TYPE (base));
for the malloc call. */
if (UNLIMITED_POLY (c))
{
- tree ctmp;
gfc_add_modify (&tmpblock, gfc_class_len_get (dcmp),
gfc_class_len_get (comp));
-
- size = gfc_evaluate_now (size, &tmpblock);
- tmp = gfc_class_len_get (comp);
- ctmp = fold_build2_loc (input_location, MULT_EXPR,
- size_type_node, size,
- fold_convert (size_type_node, tmp));
- tmp = fold_build2_loc (input_location, GT_EXPR,
- logical_type_node, tmp,
- build_zero_cst (TREE_TYPE (tmp)));
- size = fold_build3_loc (input_location, COND_EXPR,
- size_type_node, tmp, ctmp, size);
- size = gfc_evaluate_now (size, &tmpblock);
+ size = gfc_resize_class_size_with_len (&tmpblock, comp, size);
}
/* Coarray component have to have the same allocation status and
tree alloc_expr;
tree size1;
tree size2;
+ tree elemsize1;
+ tree elemsize2;
tree array1;
tree cond_null;
tree cond;
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
array1 = gfc_conv_descriptor_data_get (desc);
+ if (expr2)
+ desc2 = rss->info->data.array.descriptor;
+ else
+ desc2 = NULL_TREE;
+
+ /* Get the old lhs element size for deferred character and class expr1. */
+ if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+ {
+ if (expr1->ts.u.cl->backend_decl
+ && VAR_P (expr1->ts.u.cl->backend_decl))
+ elemsize1 = expr1->ts.u.cl->backend_decl;
+ else
+ elemsize1 = lss->info->string_length;
+ }
+ else if (expr1->ts.type == BT_CLASS)
+ {
+ tmp = expr1->rank ? gfc_get_class_from_expr (desc) : NULL_TREE;
+ if (tmp != NULL_TREE)
+ {
+ tmp2 = gfc_class_vptr_get (tmp);
+ cond = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node, tmp2,
+ build_int_cst (TREE_TYPE (tmp2), 0));
+ elemsize1 = gfc_class_vtab_size_get (tmp);
+ elemsize1 = fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type, cond,
+ elemsize1, gfc_index_zero_node);
+ }
+ else
+ elemsize1 = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr1)->ts));
+ }
+ else
+ elemsize1 = NULL_TREE;
+ if (elemsize1 != NULL_TREE)
+ elemsize1 = gfc_evaluate_now (elemsize1, &fblock);
+
+ /* Get the new lhs size in bytes. */
+ if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
+ {
+ if (expr2->ts.deferred)
+ {
+ if (expr2->ts.u.cl->backend_decl
+ && VAR_P (expr2->ts.u.cl->backend_decl))
+ tmp = expr2->ts.u.cl->backend_decl;
+ else
+ tmp = rss->info->string_length;
+ }
+ else
+ {
+ tmp = expr2->ts.u.cl->backend_decl;
+ if (!tmp && expr2->expr_type == EXPR_OP
+ && expr2->value.op.op == INTRINSIC_CONCAT)
+ {
+ tmp = concat_str_length (expr2);
+ expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
+ }
+ else if (!tmp && expr2->ts.u.cl->length)
+ {
+ gfc_se tmpse;
+ gfc_init_se (&tmpse, NULL);
+ gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length,
+ gfc_charlen_type_node);
+ tmp = tmpse.expr;
+ expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
+ }
+ tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
+ }
+
+ if (expr1->ts.u.cl->backend_decl
+ && VAR_P (expr1->ts.u.cl->backend_decl))
+ gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
+ else
+ gfc_add_modify (&fblock, lss->info->string_length, tmp);
+
+ if (expr1->ts.kind > 1)
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ TREE_TYPE (tmp),
+ tmp, build_int_cst (TREE_TYPE (tmp),
+ expr1->ts.kind));
+ }
+ else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
+ {
+ tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, tmp,
+ expr1->ts.u.cl->backend_decl);
+ }
+ else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
+ tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
+ else if (expr1->ts.type == BT_CLASS && expr2->ts.type == BT_CLASS)
+ {
+ tmp = expr2->rank ? gfc_get_class_from_expr (desc2) : NULL_TREE;
+ if (tmp != NULL_TREE)
+ tmp = gfc_class_vtab_size_get (tmp);
+ else
+ tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr2)->ts));
+ }
+ else
+ tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
+ elemsize2 = fold_convert (gfc_array_index_type, tmp);
+ elemsize2 = gfc_evaluate_now (elemsize2, &fblock);
+
/* 7.4.1.3 "If variable is an allocated allocatable variable, it is
deallocated if expr is an array of different shape or any of the
corresponding length type parameter values of variable and expr
rss->info->string_length);
cond_null = fold_build2_loc (input_location, TRUTH_OR_EXPR,
logical_type_node, tmp, cond_null);
+ cond_null= gfc_evaluate_now (cond_null, &fblock);
}
else
cond_null= gfc_evaluate_now (cond_null, &fblock);
gfc_add_expr_to_block (&fblock, tmp);
}
+ /* ...else if the element lengths are not the same also go to
+ setting the bounds and doing the reallocation.... */
+ if (elemsize1 != NULL_TREE)
+ {
+ cond = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node,
+ elemsize1, elemsize2);
+ tmp = build3_v (COND_EXPR, cond,
+ build1_v (GOTO_EXPR, jump_label1),
+ build_empty_stmt (input_location));
+ 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);
gfc_add_expr_to_block (&fblock, tmp);
/* Get the rhs size and fix it. */
- if (expr2)
- desc2 = rss->info->data.array.descriptor;
- else
- desc2 = NULL_TREE;
-
size2 = gfc_index_one_node;
for (n = 0; n < expr2->rank; n++)
{
gfc_add_modify (&fblock, linfo->delta[dim], tmp);
}
- /* Get the new lhs size in bytes. */
- if (expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
- {
- if (expr2->ts.deferred)
- {
- if (expr2->ts.u.cl->backend_decl
- && VAR_P (expr2->ts.u.cl->backend_decl))
- tmp = expr2->ts.u.cl->backend_decl;
- else
- tmp = rss->info->string_length;
- }
- else
- {
- tmp = expr2->ts.u.cl->backend_decl;
- if (!tmp && expr2->expr_type == EXPR_OP
- && expr2->value.op.op == INTRINSIC_CONCAT)
- {
- tmp = concat_str_length (expr2);
- expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
- }
- else if (!tmp && expr2->ts.u.cl->length)
- {
- gfc_se tmpse;
- gfc_init_se (&tmpse, NULL);
- gfc_conv_expr_type (&tmpse, expr2->ts.u.cl->length,
- gfc_charlen_type_node);
- tmp = tmpse.expr;
- expr2->ts.u.cl->backend_decl = gfc_evaluate_now (tmp, &fblock);
- }
- tmp = fold_convert (TREE_TYPE (expr1->ts.u.cl->backend_decl), tmp);
- }
-
- if (expr1->ts.u.cl->backend_decl
- && VAR_P (expr1->ts.u.cl->backend_decl))
- gfc_add_modify (&fblock, expr1->ts.u.cl->backend_decl, tmp);
- else
- gfc_add_modify (&fblock, lss->info->string_length, tmp);
-
- if (expr1->ts.kind > 1)
- tmp = fold_build2_loc (input_location, MULT_EXPR,
- TREE_TYPE (tmp),
- tmp, build_int_cst (TREE_TYPE (tmp),
- expr1->ts.kind));
- }
- else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
- {
- tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
- tmp = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, tmp,
- expr1->ts.u.cl->backend_decl);
- }
- else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
- tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr2->ts));
- else
- tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&expr1->ts));
- tmp = fold_convert (gfc_array_index_type, tmp);
-
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
- gfc_conv_descriptor_span_set (&fblock, desc, tmp);
+ gfc_conv_descriptor_span_set (&fblock, desc, elemsize2);
size2 = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
- tmp, size2);
+ elemsize2, size2);
size2 = fold_convert (size_type_node, size2);
size2 = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
size2, size_one_node);
gfc_add_modify (&fblock, tmp,
gfc_get_dtype_rank_type (expr1->rank,type));
}
- else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
+ else if (expr1->ts.type == BT_CLASS)
{
tree type;
tmp = gfc_conv_descriptor_dtype (desc);
- type = gfc_typenode_for_spec (&expr2->ts);
+
+ if (expr2->ts.type != BT_CLASS)
+ type = gfc_typenode_for_spec (&expr2->ts);
+ else
+ type = gfc_get_character_type_len (1, elemsize2);
+
gfc_add_modify (&fblock, tmp,
gfc_get_dtype_rank_type (expr2->rank,type));
/* Set the _len field as well... */
- tmp = gfc_class_len_get (TREE_OPERAND (desc, 0));
- if (expr2->ts.type == BT_CHARACTER)
- gfc_add_modify (&fblock, tmp,
- fold_convert (TREE_TYPE (tmp),
- TYPE_SIZE_UNIT (type)));
- else
- gfc_add_modify (&fblock, tmp,
- build_int_cst (TREE_TYPE (tmp), 0));
+ if (UNLIMITED_POLY (expr1))
+ {
+ tmp = gfc_class_len_get (TREE_OPERAND (desc, 0));
+ if (expr2->ts.type == BT_CHARACTER)
+ gfc_add_modify (&fblock, tmp,
+ fold_convert (TREE_TYPE (tmp),
+ TYPE_SIZE_UNIT (type)));
+ else
+ gfc_add_modify (&fblock, tmp,
+ build_int_cst (TREE_TYPE (tmp), 0));
+ }
/* ...and the vptr. */
tmp = gfc_class_vptr_get (TREE_OPERAND (desc, 0));
- tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
- tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
- gfc_add_modify (&fblock, tmp, tmp2);
+ if (expr2->ts.type == BT_CLASS && !VAR_P (desc2)
+ && TREE_CODE (desc2) == COMPONENT_REF)
+ {
+ tmp2 = gfc_get_class_from_expr (desc2);
+ tmp2 = gfc_class_vptr_get (tmp2);
+ }
+ else
+ {
+ tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));
+ tmp2 = gfc_build_addr_expr (TREE_TYPE (tmp), tmp2);
+ }
+
+ gfc_add_modify (&fblock, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
}
else if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
{
gfc_add_block_to_block (&realloc_block, &caf_se.post);
realloc_expr = gfc_finish_block (&realloc_block);
- /* Only reallocate if sizes are different. */
+ /* Reallocate if sizes or dynamic types are different. */
+ if (elemsize1)
+ {
+ tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+ elemsize1, elemsize2);
+ tmp = gfc_evaluate_now (tmp, &fblock);
+ neq_size = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ logical_type_node, neq_size, tmp);
+ }
tmp = build3_v (COND_EXPR, neq_size, realloc_expr,
build_empty_stmt (input_location));
- realloc_expr = tmp;
+ realloc_expr = tmp;
/* Malloc expression. */
gfc_init_block (&alloc_block);
alloc_expr = gfc_finish_block (&alloc_block);
/* Malloc if not allocated; realloc otherwise. */
- tmp = build_int_cst (TREE_TYPE (array1), 0);
- cond = fold_build2_loc (input_location, EQ_EXPR,
- logical_type_node,
- array1, tmp);
- tmp = build3_v (COND_EXPR, cond, alloc_expr, realloc_expr);
+ tmp = build3_v (COND_EXPR, cond_null, alloc_expr, realloc_expr);
gfc_add_expr_to_block (&fblock, tmp);
/* Make sure that the scalarizer data pointer is updated. */
gfc_add_modify (&fblock, linfo->data, tmp);
}
- /* Add the exit label. */
+ /* Add the label for same shape lhs and rhs. */
tmp = build1_v (LABEL_EXPR, jump_label2);
gfc_add_expr_to_block (&fblock, tmp);
}
+tree
+gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size)
+{
+ tree tmp;
+ tree tmp2;
+ tree type;
+
+ tmp = gfc_class_len_or_zero_get (class_expr);
+
+ /* Include the len value in the element size if present. */
+ if (!integer_zerop (tmp))
+ {
+ type = TREE_TYPE (size);
+ if (block)
+ {
+ size = gfc_evaluate_now (size, block);
+ tmp = gfc_evaluate_now (fold_convert (type , tmp), block);
+ }
+ tmp2 = fold_build2_loc (input_location, MULT_EXPR,
+ type, size, tmp);
+ tmp = fold_build2_loc (input_location, GT_EXPR,
+ logical_type_node, tmp,
+ build_zero_cst (type));
+ size = fold_build3_loc (input_location, COND_EXPR,
+ type, tmp, tmp2, size);
+ }
+ else
+ return size;
+
+ if (block)
+ size = gfc_evaluate_now (size, block);
+
+ return size;
+}
+
+
/* Get the specified FIELD from the VPTR. */
static tree
for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0))
{
+ if (CONSTANT_CLASS_P (tmp))
+ return NULL_TREE;
+
type = TREE_TYPE (tmp);
while (type)
{
}
+/* Class valued elemental function calls or class array elements arriving
+ in gfc_trans_scalar_assign come here. Wherever possible the vptr copy
+ is used to ensure that the rhs dynamic type is assigned to the lhs. */
+
+static bool
+trans_scalar_class_assign (stmtblock_t *block, gfc_se *lse, gfc_se *rse)
+{
+ tree fcn;
+ tree rse_expr;
+ tree class_data;
+ tree tmp;
+ tree zero;
+ tree cond;
+ tree final_cond;
+ stmtblock_t inner_block;
+ bool is_descriptor;
+ bool not_call_expr = TREE_CODE (rse->expr) != CALL_EXPR;
+ bool not_lhs_array_type;
+
+ /* Temporaries arising from depencies in assignment get cast as a
+ character type of the dynamic size of the rhs. Use the vptr copy
+ for this case. */
+ tmp = TREE_TYPE (lse->expr);
+ not_lhs_array_type = !(tmp && TREE_CODE (tmp) == ARRAY_TYPE
+ && TYPE_MAX_VALUE (TYPE_DOMAIN (tmp)) != NULL_TREE);
+
+ /* Use ordinary assignment if the rhs is not a call expression or
+ the lhs is not a class entity or an array(ie. character) type. */
+ if ((not_call_expr && gfc_get_class_from_expr (lse->expr) == NULL_TREE)
+ && not_lhs_array_type)
+ return false;
+
+ /* Ordinary assignment can be used if both sides are class expressions
+ since the dynamic type is preserved by copying the vptr. This
+ should only occur, where temporaries are involved. */
+ if (GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
+ && GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
+ return false;
+
+ /* Fix the class expression and the class data of the rhs. */
+ if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr))
+ || not_call_expr)
+ {
+ tmp = gfc_get_class_from_expr (rse->expr);
+ if (tmp == NULL_TREE)
+ return false;
+ rse_expr = gfc_evaluate_now (tmp, block);
+ }
+ else
+ rse_expr = gfc_evaluate_now (rse->expr, block);
+
+ class_data = gfc_class_data_get (rse_expr);
+
+ /* Check that the rhs data is not null. */
+ is_descriptor = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (class_data));
+ if (is_descriptor)
+ class_data = gfc_conv_descriptor_data_get (class_data);
+ class_data = gfc_evaluate_now (class_data, block);
+
+ zero = build_int_cst (TREE_TYPE (class_data), 0);
+ cond = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node,
+ class_data, zero);
+
+ /* Copy the rhs to the lhs. */
+ fcn = gfc_vptr_copy_get (gfc_class_vptr_get (rse_expr));
+ fcn = build_fold_indirect_ref_loc (input_location, fcn);
+ tmp = gfc_evaluate_now (gfc_build_addr_expr (NULL, rse->expr), block);
+ tmp = is_descriptor ? tmp : class_data;
+ tmp = build_call_expr_loc (input_location, fcn, 2, tmp,
+ gfc_build_addr_expr (NULL, lse->expr));
+ gfc_add_expr_to_block (block, tmp);
+
+ /* Only elemental function results need to be finalised and freed. */
+ if (not_call_expr)
+ return true;
+
+ /* Finalize the class data if needed. */
+ gfc_init_block (&inner_block);
+ fcn = gfc_vptr_final_get (gfc_class_vptr_get (rse_expr));
+ zero = build_int_cst (TREE_TYPE (fcn), 0);
+ final_cond = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node, fcn, zero);
+ fcn = build_fold_indirect_ref_loc (input_location, fcn);
+ tmp = build_call_expr_loc (input_location, fcn, 1, class_data);
+ tmp = build3_v (COND_EXPR, final_cond,
+ tmp, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&inner_block, tmp);
+
+ /* Free the class data. */
+ tmp = gfc_call_free (class_data);
+ tmp = build3_v (COND_EXPR, cond, tmp,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&inner_block, tmp);
+
+ /* Finish the inner block and subject it to the condition on the
+ class data being non-zero. */
+ tmp = gfc_finish_block (&inner_block);
+ tmp = build3_v (COND_EXPR, cond, tmp,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (block, tmp);
+
+ return true;
+}
+
/* End of prototype trans-class.c */
{
/* The intrinsic type needs to be converted to a temporary
CLASS object for the unlimited polymorphic formal. */
+ gfc_find_vtab (&e->ts);
gfc_init_se (&parmse, se);
gfc_conv_intrinsic_to_class (&parmse, e, fsym->ts);
+
}
else if (se->ss && se->ss->info->useflags)
{
tree tmp, to_len = NULL_TREE, from_len = NULL_TREE, lhs_vptr;
bool set_vptr = false, temp_rhs = false;
stmtblock_t *pre = block;
+ tree class_expr = NULL_TREE;
/* Create a temporary for complicated expressions. */
if (re->expr_type != EXPR_VARIABLE && re->expr_type != EXPR_NULL
&& rse->expr != NULL_TREE && !DECL_P (rse->expr))
{
- tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
- pre = &rse->pre;
- gfc_add_modify (&rse->pre, tmp, rse->expr);
+ if (re->ts.type == BT_CLASS && !GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
+ class_expr = gfc_get_class_from_expr (rse->expr);
+
+ if (rse->loop)
+ pre = &rse->loop->pre;
+ else
+ pre = &rse->pre;
+
+ if (class_expr != NULL_TREE && UNLIMITED_POLY (re))
+ {
+ tmp = TREE_OPERAND (rse->expr, 0);
+ tmp = gfc_create_var (TREE_TYPE (tmp), "rhs");
+ gfc_add_modify (&rse->pre, tmp, TREE_OPERAND (rse->expr, 0));
+ }
+ else
+ {
+ tmp = gfc_create_var (TREE_TYPE (rse->expr), "rhs");
+ gfc_add_modify (&rse->pre, tmp, rse->expr);
+ }
+
rse->expr = tmp;
temp_rhs = true;
}
else if (temp_rhs && re->ts.type == BT_CLASS)
{
vptr_expr = NULL;
- se.expr = gfc_class_vptr_get (rse->expr);
+ if (class_expr)
+ tmp = class_expr;
+ else if (!GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)))
+ tmp = gfc_get_class_from_expr (rse->expr);
+ else
+ tmp = rse->expr;
+
+ se.expr = gfc_class_vptr_get (tmp);
if (UNLIMITED_POLY (re))
- from_len = gfc_class_len_get (rse->expr);
+ from_len = gfc_class_len_get (tmp);
+
}
else if (re->expr_type != EXPR_NULL)
/* Only when rhs is non-NULL use its declared type for vptr
gfc_add_expr_to_block (&block, tmp);
}
}
- else if (gfc_bt_struct (ts.type) || ts.type == BT_CLASS)
+ else if (gfc_bt_struct (ts.type))
{
gfc_add_block_to_block (&block, &lse->pre);
gfc_add_block_to_block (&block, &rse->pre);
TREE_TYPE (lse->expr), rse->expr);
gfc_add_modify (&block, lse->expr, tmp);
}
- else
+ /* If possible use the rhs vptr copy with trans_scalar_class_assign.... */
+ else if (ts.type == BT_CLASS
+ && !trans_scalar_class_assign (&block, lse, rse))
+ {
+ gfc_add_block_to_block (&block, &lse->pre);
+ gfc_add_block_to_block (&block, &rse->pre);
+ /* ...otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
+ for the lhs which ensures that class data rhs cast as a string assigns
+ correctly. */
+ tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
+ TREE_TYPE (rse->expr), lse->expr);
+ gfc_add_modify (&block, tmp, rse->expr);
+ }
+ else if (ts.type != BT_CLASS)
{
gfc_add_block_to_block (&block, &lse->pre);
gfc_add_block_to_block (&block, &rse->pre);
gfc_se *lse, gfc_se *rse, bool use_vptr_copy,
bool class_realloc)
{
- tree tmp, fcn, stdcopy, to_len, from_len, vptr;
+ tree tmp, fcn, stdcopy, to_len, from_len, vptr, old_vptr;
vec<tree, va_gc> *args = NULL;
+ /* Store the old vptr so that dynamic types can be compared for
+ reallocation to occur or not. */
+ if (class_realloc)
+ {
+ tmp = lse->expr;
+ if (!GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+ tmp = gfc_get_class_from_expr (tmp);
+ }
+
vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len,
&from_len);
- /* Generate allocation of the lhs. */
+ /* Generate (re)allocation of the lhs. */
if (class_realloc)
{
- stmtblock_t alloc;
- tree class_han;
+ stmtblock_t alloc, re_alloc;
+ tree class_han, re, size;
- tmp = gfc_vptr_size_get (vptr);
+ if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+ old_vptr = gfc_evaluate_now (gfc_class_vptr_get (tmp), block);
+ else
+ old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
+
+ size = gfc_vptr_size_get (vptr);
class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr))
? gfc_class_data_get (lse->expr) : lse->expr;
+
+ /* Allocate block. */
gfc_init_block (&alloc);
- gfc_allocate_using_malloc (&alloc, class_han, tmp, NULL_TREE);
+ gfc_allocate_using_malloc (&alloc, class_han, size, NULL_TREE);
+
+ /* Reallocate if dynamic types are different. */
+ gfc_init_block (&re_alloc);
+ re = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_REALLOC), 2,
+ fold_convert (pvoid_type_node, class_han),
+ size);
+ tmp = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node, vptr, old_vptr);
+ re = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ tmp, re, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&re_alloc, re);
+
+ /* Allocate if _data is NULL, reallocate otherwise. */
tmp = fold_build2_loc (input_location, EQ_EXPR,
logical_type_node, class_han,
build_int_cst (prvoid_type_node, 0));
gfc_unlikely (tmp,
PRED_FORTRAN_FAIL_ALLOC),
gfc_finish_block (&alloc),
- build_empty_stmt (input_location));
+ gfc_finish_block (&re_alloc));
gfc_add_expr_to_block (&lse->pre, tmp);
}
bool maybe_workshare = false, lhs_refs_comp = false, rhs_refs_comp = false;
symbol_attribute lhs_caf_attr, rhs_caf_attr, lhs_attr;
bool is_poly_assign;
+ bool realloc_flag;
/* Assignment of the form lhs = rhs. */
gfc_start_block (&block);
|| gfc_is_class_array_ref (expr2, NULL)
|| gfc_is_class_scalar_expr (expr2));
+ realloc_flag = flag_realloc_lhs
+ && gfc_is_reallocatable_lhs (expr1)
+ && expr2->rank
+ && !is_runtime_conformable (expr1, expr2);
/* Only analyze the expressions for coarray properties, when in coarray-lib
mode. */
if (is_poly_assign)
tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
use_vptr_copy || (lhs_attr.allocatable
- && !lhs_attr.dimension),
- flag_realloc_lhs && !lhs_attr.pointer);
+ && !lhs_attr.dimension),
+ !realloc_flag && flag_realloc_lhs
+ && !lhs_attr.pointer);
else if (flag_coarray == GFC_FCOARRAY_LIB
&& lhs_caf_attr.codimension && rhs_caf_attr.codimension
&& ((lhs_caf_attr.allocatable && lhs_refs_comp)
{
/* This case comes about when the scalarizer provides array element
references. Use the vptr copy function, since this does a deep
- copy of allocatable components, without which the finalizer call */
+ copy of allocatable components, without which the finalizer call
+ will deallocate the components. */
tmp = gfc_get_vptr_from_expr (rse.expr);
if (tmp != NULL_TREE)
{
}
/* F2003: Allocate or reallocate lhs of allocatable array. */
- if (flag_realloc_lhs
- && gfc_is_reallocatable_lhs (expr1)
- && expr2->rank
- && !is_runtime_conformable (expr1, expr2))
+ if (realloc_flag)
{
realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
ompws_flags &= ~OMPWS_SCALARIZER_WS;
return tmp;
}
- if (UNLIMITED_POLY (expr1) && expr1->rank
- && expr2->ts.type != BT_CLASS)
+ if (UNLIMITED_POLY (expr1) && expr1->rank)
use_vptr_copy = true;
/* Fallback to the scalarizer to generate explicit loops. */
/* Check if this is an unlimited polymorphic object carrying a character
payload. In this case, the 'len' field is non-zero. */
if (decl && GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
- {
- tmp = gfc_class_len_or_zero_get (decl);
- if (!integer_zerop (tmp))
- {
- tree cond;
- tree stype = TREE_TYPE (span);
- tmp = fold_convert (stype, tmp);
- cond = fold_build2_loc (input_location, EQ_EXPR,
- logical_type_node, tmp,
- build_int_cst (stype, 0));
- tmp = fold_build2 (MULT_EXPR, stype, span, tmp);
- span = fold_build3_loc (input_location, COND_EXPR, stype,
- cond, span, tmp);
- }
- }
+ span = gfc_resize_class_size_with_len (NULL, decl, span);
}
else if (decl)
span = get_array_span (type, decl);
tree gfc_class_vptr_get (tree);
tree gfc_class_len_get (tree);
tree gfc_class_len_or_zero_get (tree);
+tree gfc_resize_class_size_with_len (stmtblock_t *, tree, tree);
gfc_expr * gfc_find_and_cut_at_last_class_ref (gfc_expr *, bool is_mold = false);
/* Get an accessor to the class' vtab's * field, when a class handle is
available. */
--- /dev/null
+! { dg-do run }
+! { dg-options "-fdump-tree-original" }
+!
+! In the course of fixing PR83118, lots of issues came up with class array
+! assignment, where temporaries are generated. This testcase checks that
+! the use of assignment by allocate with source is OK, especially with array
+! constructors using class arrays. While this test did run previously, the
+! temporaries for such arrays were malformed with the class as the type and
+! element lengths of 72 bytes rather than the 4 bytes of the decalred type.
+!
+! Contributed by Dominique d'Humieres <dhumieres.dominique@free.fr>
+!
+type t1
+ integer :: i = 5
+end type t1
+type, extends(t1) :: t2
+ integer :: j = 6
+end type t2
+
+class(t1), allocatable :: a(:), b(:), c(:)
+integer :: i
+
+allocate(t2 :: a(3))
+allocate(t2 :: b(5))
+if (.not.check_t1 (a, [(5, i = 1, 3)], 2)) stop 1
+
+allocate(c, source=[a, b ]) ! F2008, PR 44672
+if (.not.check_t1 (c, [(5, i = 1, 8)], 1)) stop 2
+
+deallocate(c)
+allocate(c(8), source=[ a, b ])
+if (.not.check_t1 (c, [(5, i = 1, 8)], 1)) stop 3
+
+deallocate(c)
+c = [t1 :: a, b ] ! F2008, PR 43366
+if (.not.check_t1 (c, [(5, i = 1, 8)], 1)) stop 4
+deallocate(a, b, c)
+
+contains
+
+ logical function check_t1 (arg, array, t)
+ class(t1) :: arg(:)
+ integer :: array (:), t
+ check_t1 = .true.
+ select type (arg)
+ type is (t1)
+ if (any (arg%i .ne. array)) check_t1 = .false.
+ if (t .eq. 2) check_t1 = .false.
+ type is (t2)
+ if (any (arg%i .ne. array)) check_t1 = .false.
+ if (t .eq. 1) check_t1 = .false.
+ class default
+ check_t1 = .false.
+ end select
+ end function check_t1
+
+end
+! { dg-final { scan-tree-dump-times "elem_len=72" 0 "original" } }
--- /dev/null
+! { dg-do run }
+!
+! In the course of fixing PR83118, lots of issues came up with class array
+! assignment, where temporaries are generated. This testcase checks that
+! it all works correctly.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+module m
+ implicit none
+ type :: t1
+ integer :: i
+ CONTAINS
+ PROCEDURE :: add_t1
+ GENERIC :: OPERATOR(+) => add_t1
+ end type
+ type, extends(t1) :: t2
+ real :: r
+ end type
+
+contains
+ impure elemental function add_t1 (a, b) result (c)
+ class(t1), intent(in) :: a, b
+ class(t1), allocatable :: c
+ allocate (c, source = a)
+ c%i = a%i + b%i
+ select type (c)
+ type is (t2)
+ select type (b)
+ type is (t2)
+ c%r = c%r + b%r
+ end select
+ end select
+ end function add_t1
+
+end module m
+
+subroutine test_t1
+ use m
+ implicit none
+
+ class(t1), dimension(:), allocatable :: x, y
+
+ x = [t2(1,10.0),t2(2,20.0),t2(3,30.0)]
+ if (.not.check_t1 (x, [1,2,3], 2, [10, 20, 30]) ) stop 1
+
+ y = x
+ x = realloc_t1 (y)
+ if (.not.check_t1 (x, [3,2,1], 1) ) stop 2
+
+ x = realloc_t1 (x)
+ if (.not.check_t1 (x, [2,3,1], 1) ) stop 3
+
+ x = x([3,1,2])
+ if (.not.check_t1 (x, [1,2,3], 1) ) stop 4
+
+ x = x(3:1:-1) + y
+ if (.not.check_t1 (x, [4,4,4], 1) ) stop 5
+
+ x = y + x(3:1:-1)
+ if (.not.check_t1 (x, [5,6,7], 2) ) stop 6
+
+! Now check that the dynamic type survives assignments.
+ x = [t2(1,10.0),t2(2,20.0),t2(3,30.0)]
+ y = x
+
+ x = y(3:1:-1)
+ if (.not.check_t1 (x, [3,2,1], 2, [30,20,10]) ) stop 7
+
+ x = x(3:1:-1) + y
+ if (.not.check_t1 (x, [2,4,6], 2, [20,40,60]) ) stop 8
+
+ x = x(3:1:-1)
+ if (.not.check_t1 (x, [6,4,2], 2, [60,40,20]) ) stop 9
+
+ x = x([3,2,1])
+ if (.not.check_t1 (x, [2,4,6], 2, [20,40,60]) ) stop 10
+
+contains
+
+ function realloc_t1 (arg) result (res)
+ class(t1), dimension(:), allocatable :: arg
+ class(t1), dimension(:), allocatable :: res
+ select type (arg)
+ type is (t2)
+ allocate (res, source = [t1 (arg(3)%i), t1 (arg(2)%i), t1 (arg(1)%i)])
+ type is (t1)
+ allocate (res, source = [t1 (arg(2)%i), t1 (arg(1)%i), t1 (arg(3)%i)])
+ end select
+ end function realloc_t1
+
+ logical function check_t1 (arg, array, t, array2)
+ class(t1) :: arg(:)
+ integer :: array (:), t
+ integer, optional :: array2(:)
+ check_t1 = .true.
+ select type (arg)
+ type is (t1)
+ if (any (arg%i .ne. array)) check_t1 = .false.
+ if (t .eq. 2) check_t1 = .false.
+ type is (t2)
+ if (any (arg%i .ne. array)) check_t1 = .false.
+ if (t .eq. 1) check_t1 = .false.
+ if (present (array2)) then
+ if (any(int (arg%r) .ne. array2)) check_t1 = .false.
+ end if
+ class default
+ check_t1 = .false.
+ end select
+ end function check_t1
+
+end subroutine test_t1
+
+subroutine test_star
+ use m
+ implicit none
+
+ class(*), dimension(:), allocatable :: x, y
+
+ x = [t2(1,10.0),t2(2,20.0),t2(3,30.0)]
+ if (.not.check_star (x, [1,2,3], 2) ) stop 11
+
+ y = x
+ x = realloc_star (y)
+ if (.not.check_star (x, [3,2,1], 1) ) stop 12
+
+ x = realloc_star (x)
+ if (.not.check_star (x, [2,3,1], 1) ) stop 13
+
+ x = x([3,1,2])
+ if (.not.check_star (x, [1,2,3], 1) ) stop 14
+
+ x = x(3:1:-1)
+ if (.not.check_star (x, [3,2,1], 1) ) stop 15
+
+! Make sure that all is similarly well with type t2.
+ x = [t2(1,10.0),t2(2,20.0),t2(3,30.0)]
+
+ x = x([3,1,2])
+ if (.not.check_star (x, [3,1,2], 2, [30,10,20]) ) stop 16
+
+ x = x(3:1:-1)
+ if (.not.check_star (x, [2,1,3], 2, [20,10,30]) ) stop 17
+
+contains
+
+ function realloc_star (arg) result (res)
+ class(*), dimension(:), allocatable :: arg
+ class(*), dimension(:), allocatable :: res
+ select type (arg)
+ type is (t2)
+ allocate (res, source = [t1 (arg(3)%i), t1 (arg(2)%i), t1 (arg(1)%i)])
+ type is (t1)
+ allocate (res, source = [t1 (arg(2)%i), t1 (arg(1)%i), t1 (arg(3)%i)])
+ end select
+ end function realloc_star
+
+ logical function check_star (arg, array, t, array2)
+ class(*) :: arg(:)
+ integer :: array (:), t
+ integer, optional :: array2(:)
+ check_star = .true.
+ select type (arg)
+ type is (t1)
+ if (any (arg%i .ne. array)) check_star = .false.
+ if (t .eq. 2) check_star = .false.
+ type is (t2)
+ if (any (arg%i .ne. array)) check_star = .false.
+ if (t .eq. 1) check_star = .false.
+ if (present (array2)) then
+ if (any (int(arg%r) .ne. array2)) check_star = .false.
+ endif
+ class default
+ check_star = .false.
+ end select
+ end function check_star
+
+end subroutine test_star
+
+
+ call test_t1
+ call test_star
+end
--- /dev/null
+! { dg-do run }
+! PR 92755 - this used to cause an ICE (see dependency_57.f90)
+! PR83118 - fixed so that it would run :-)
+! Original test case by Gerhard Steinmetz
+program p
+ type t
+ integer :: i
+ end type
+ type t2
+ class(t), allocatable :: a(:)
+ end type
+ type(t2) :: z
+ z%a = [t(1),t(2),t(3)]
+ z%a = [z%a]
+ select type (y => z%a)
+ type is (t)
+ if (any (y%i .ne. [1, 2, 3])) stop 1
+ end select
+end
--- /dev/null
+! { dg-do run }
+!
+! Test the fix of the test case referenced in comment 17 of PR83118.
+!
+! Contributed by Damian Rouson <damian@sourceryinstitute.org>
+!
+ implicit none
+ type Wrapper
+ class(*), allocatable :: elements(:)
+ end type
+ type Mytype
+ real(4) :: r = 42.0
+ end type
+
+ call driver
+contains
+ subroutine driver
+ class(*), allocatable :: obj
+ type(Wrapper) w
+ integer(4) :: expected4(2) = [42_4, 43_4]
+ integer(8) :: expected8(3) = [42_8, 43_8, 44_8]
+
+ w = new_wrapper (expected4)
+ obj = w
+ call test (obj, 0)
+ obj = new_wrapper (expected8) ! Used to generate a linker error
+ call test (obj, 10)
+ obj = new_wrapper ([mytype (99.0)])
+ call test (obj, 100)
+ obj = Mytype (42.0) ! Used to generate a linker error
+ call test (obj, 1000)
+ end subroutine
+ function new_wrapper(array) result (res)
+ class(*) :: array(:)
+ type(Wrapper) :: res
+ res%elements = array ! Used to runtime segfault
+ end function
+ subroutine test (arg, idx)
+ class(*) :: arg
+ integer :: idx
+ select type (arg)
+ type is (wrapper)
+ select type (z => arg%elements)
+ type is (integer(4))
+ if (any (z .ne. [42_4, 43_4])) stop 1 + idx
+ type is (integer(8))
+ if (any (z .ne. [42_8, 43_8, 44_8])) stop 1 + idx
+ type is (Mytype)
+ if (abs (z(1)%r - 99.0) .ge. 1e-6) stop 1 + idx
+ class default
+ stop 2 + idx
+ end select
+ type is (Mytype)
+ if (abs (arg%r - 42.0) .ge. 1e-6) stop 1 + idx
+ class default
+ stop 3 + idx
+ end select
+ end subroutine
+end
projects / gcc.git / commitdiff