@@ -11054,7 +11054,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
/* 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 (UNLIMITED_POLY (lhs) && rhs->ts.type != BT_CLASS)
gfc_find_vtab (&rhs->ts);
bool caf_convert_to_send = flag_coarray == GFC_FCOARRAY_LIB
@@ -1030,7 +1030,6 @@ gfc_trans_allocate_array_storage (stmtblock_t * pre, stmtblock_t * post,
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,
@@ -1139,6 +1138,112 @@ get_array_ref_dim_for_loop_dim (gfc_ss *ss, int loop_dim)
}
+/* 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;
+ 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);
+ }
+
+ /* 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->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_class_expr = gfc_get_class_from_expr (tmp);
+ else
+ return NULL_TREE;
+
+ 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);
+ }
+ }
+ 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
@@ -1184,13 +1289,44 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
{
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);
+ gcc_assert ((class_expr != NULL_TREE)
+ || !GFC_CLASS_TYPE_P (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);
+ eltype = gfc_get_character_type_len (1, elemsize);
+ }
+
memset (from, 0, sizeof (from));
memset (to, 0, sizeof (to));
@@ -1339,12 +1475,6 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
}
}
- 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)
{
@@ -3373,18 +3503,10 @@ build_class_array_ref (gfc_se *se, tree base, tree index)
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));
@@ -9233,21 +9355,9 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
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
@@ -10033,6 +10143,8 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
tree alloc_expr;
tree size1;
tree size2;
+ tree elemsize1;
+ tree elemsize2;
tree array1;
tree cond_null;
tree cond;
@@ -10112,6 +10224,108 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
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
@@ -10131,6 +10345,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
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);
@@ -10179,6 +10394,19 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
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);
@@ -10201,11 +10429,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
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++)
{
@@ -10320,69 +10543,12 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
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);
@@ -10403,7 +10569,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
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);
@@ -10411,19 +10577,32 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
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)))
{
@@ -10499,11 +10678,19 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
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);
@@ -10550,11 +10737,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
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. */
@@ -10564,7 +10747,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
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);
@@ -257,6 +257,42 @@ gfc_class_len_or_zero_get (tree decl)
}
+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
@@ -5613,8 +5649,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
{
/* 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)
{
@@ -8926,14 +8964,32 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
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;
}
@@ -9001,9 +9057,17 @@ trans_class_vptr_len_assignment (stmtblock_t *block, gfc_expr * le,
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
@@ -9810,8 +9874,12 @@ arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
return true;
/* Functions returning pointers or allocatables need temporaries. */
- if (gfc_expr_attr (expr2).pointer
- || gfc_expr_attr (expr2).allocatable)
+ c = expr2->value.function.esym
+ ? (expr2->value.function.esym->attr.pointer
+ || expr2->value.function.esym->attr.allocatable)
+ : (expr2->symtree->n.sym->attr.pointer
+ || expr2->symtree->n.sym->attr.allocatable);
+ if (c)
return true;
/* Character array functions need temporaries unless the
@@ -10666,23 +10734,53 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
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));
@@ -10690,7 +10788,7 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
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);
}
@@ -10793,6 +10891,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
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);
@@ -10833,6 +10932,10 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
|| 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. */
@@ -11077,8 +11180,9 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
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)
@@ -11183,10 +11287,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
}
/* 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;
@@ -11295,8 +11396,7 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
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. */
@@ -435,21 +435,7 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr)
/* 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);
@@ -423,6 +423,7 @@ tree gfc_class_data_get (tree);
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. */
@@ -1,12 +1,18 @@
-! { dg-do compile }
+! { dg-do run }
! PR 92755 - this used to cause an ICE.
! 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
Hi Everyone, I am afraid that this is a rather long sad story, mainly due to my efforts with gfortran being interrupted by daytime work. I posted the first version of the patch nearly a year ago but this was derailed by Tobias's question at: https://gcc.gnu.org/legacy-ml/fortran/2019-11/msg00098.html My recent attempt to post this patch were disrupted by the patch itself disappearing from the posting. Thanks to Andre and Thomas for pointing this out. Since then, I have been working on downstream PRs and this has led to a reworking of the unposted version. (i) The attached fixes the original problem and is tested by gfortran.dg/unlimited_polymorphic_32.f03. (ii) In fixing the original problem, a fair amount of effort was required to get the element length correct for class temporaries produced by dependencies in class assignment. This is reflected in the changes to trans_array.c(gfc_alloc_allocatable_for_assignment) and the new function get_class_info_from_ss. (iii) Tobias's testcase in the above posting to the list didn't address itself to class arrays of the original problem. However, it revealed that reallocation was not occuring at all for scalar assignments. This is fixed by the large chunk in trans-expr.c(trans_class_assignment). The array case is 'fixed' by testing for unequal element sizes between lhs and rhs before reallocation in gfc_alloc_allocatable_for_assignment. This is difficult to test for since, in most cases, the system returns that same address after reallocation. (iv) dependency_57.f90 segfaulted at runtime. The other work in trans_class_assignment was required to fix this. (v) A number of minor tidy ups were done including the new function gfc_resize_class_size_with_len to eliminate some repeated code. Note: Chunks of code are coming within scalarization loops that should be outside: x->_vptr = (struct __vtype__STAR * {ref-all}) &__vtab_INTEGER_4_; x->_len = 0; D.3977 = x->_vptr->_size; D.3978 = x->_len; D.3979 = D.3978 > 0 ? D.3977 * D.3978 : D.3977; also in many cases of class assignment, the lhs vptr is being set more than once outside the loop when temporaries are involved. I will try to iron out these issues later on. This all bootstraps and regtests on FC31/x86_64 - OK for master? Cheers Paul As well as the PR this patch fixes problems in handling class objects; most importantly class array temporaries, required when dependences occur in class assignment, and a correct implementation of reallocation on assignment. 2020-11-10 Paul Thomas <pault@gcc.gnu.org> gcc/fortran PR fortran/83118 * resolve.c (resolve_ordinary_assign): Generate a vtable if necessary for scalar non-polymorphic rhs's to unlimited lhs's. * trans-array.c (get_class_info_from_ss): New function. (gfc_trans_allocate_array_storage): Defer obtaining class element type until all sources of class exprs are tried. Use class API rather than TREE_OPERAND. Look for class expressions in ss->info by calling get_class_info_from_ss. After obtain the element size for class descriptors. Where the element type is unknown, cast the data as character(len=size) to overcome unlimited polymorphic problems. (structure_alloc_comps): Replace code that replicates the new function gfc_resize_class_size_with_len. (gfc_alloc_allocatable_for_assignment): Obtain element size for lhs in cases of deferred characters and class enitities. Move code for the element size of rhs to start of block. Clean up extraction of class parameters throughout this function. After the shape check test whether or not the lhs and rhs element sizes are the same. Use earlier evaluation of 'cond_null'. Reallocation of lhs only to happen if size changes or element size changes. * trans-expr.c (gfc_resize_class_size_with_len): New function. (gfc_conv_procedure_call): Ensure the vtable is present for passing a non-class actual to an unlimited formal. (trans_class_vptr_len_assignment): For expressions of type BT_CLASS, extract the class expression if necessary. Use a statement block outside the loop body. Ensure that 'rhs' is of the correct type. Obtain rhs vptr in all circumstances. (gfc_trans_assignment_1): Simplify some of the logic with 'realloc_flag'. Set 'vptr_copy' for all array assignments to unlimited polymorphic lhs. * trans-c (gfc_build_array_ref): Call gfc_resize_class_size_ with_len to correct span for unlimited polymorphic decls. * trans.h : Add prototype for gfc_resize_class_size_with_len. gcc/testsuite/ PR fortran/83118 * gfortran.dg/dependency_57.f90: Change to dg-run and test for correct result. * gfortran.dg/unlimited_polymorphic_32.f03: New test.