aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/trans-expr.cc
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran/trans-expr.cc')
-rw-r--r--gcc/fortran/trans-expr.cc96
1 files changed, 70 insertions, 26 deletions
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 605434f4ddb..e315e2d3370 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -317,6 +317,8 @@ gfc_resize_class_size_with_len (stmtblock_t * block, tree class_expr, tree size)
size = gfc_evaluate_now (size, block);
tmp = gfc_evaluate_now (fold_convert (type , tmp), block);
}
+ else
+ tmp = fold_convert (type , tmp);
tmp2 = fold_build2_loc (input_location, MULT_EXPR,
type, size, tmp);
tmp = fold_build2_loc (input_location, GT_EXPR,
@@ -1720,6 +1722,7 @@ gfc_trans_class_init_assign (gfc_code *code)
gfc_se dst,src,memsz;
gfc_expr *lhs, *rhs, *sz;
gfc_component *cmp;
+ gfc_symbol *sym;
gfc_start_block (&block);
@@ -1736,18 +1739,25 @@ gfc_trans_class_init_assign (gfc_code *code)
/* The _def_init is always scalar. */
rhs->rank = 0;
- /* Check def_init for initializers. If this is a dummy with all default
- initializer components NULL, return NULL_TREE and use the passed value as
- required by F2018(8.5.10). */
- if (!lhs->ref && lhs->symtree->n.sym->attr.dummy)
+ /* Check def_init for initializers. If this is an INTENT(OUT) dummy with all
+ default initializer components NULL, return NULL_TREE and use the passed
+ value as required by F2018(8.5.10). */
+ sym = code->expr1->expr_type == EXPR_VARIABLE ? code->expr1->symtree->n.sym
+ : NULL;
+ if (code->op != EXEC_ALLOCATE
+ && sym && sym->attr.dummy
+ && sym->attr.intent == INTENT_OUT)
{
- cmp = rhs->ref->next->u.c.component->ts.u.derived->components;
- for (; cmp; cmp = cmp->next)
+ if (!lhs->ref && lhs->symtree->n.sym->attr.dummy)
{
- if (cmp->initializer)
- break;
- else if (!cmp->next)
- return build_empty_stmt (input_location);
+ cmp = rhs->ref->next->u.c.component->ts.u.derived->components;
+ for (; cmp; cmp = cmp->next)
+ {
+ if (cmp->initializer)
+ break;
+ else if (!cmp->next)
+ return NULL_TREE;
+ }
}
}
@@ -7879,8 +7889,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
{
gcc_assert (se->loop && info);
- /* Set the type of the array. */
- tmp = gfc_typenode_for_spec (&comp->ts);
+ /* Set the type of the array. vtable charlens are not always reliable.
+ Use the interface, if possible. */
+ if (comp->ts.type == BT_CHARACTER
+ && expr->symtree->n.sym->ts.type == BT_CLASS
+ && comp->ts.interface && comp->ts.interface->result)
+ tmp = gfc_typenode_for_spec (&comp->ts.interface->result->ts);
+ else
+ tmp = gfc_typenode_for_spec (&comp->ts);
gcc_assert (se->ss->dimen == se->loop->dimen);
/* Evaluate the bounds of the result, if known. */
@@ -8229,8 +8245,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
call the finalization function of the temporary. Note that the
nullification of allocatable components needed by the result
is done in gfc_trans_assignment_1. */
- if (expr && ((gfc_is_class_array_function (expr)
- && se->ss && se->ss->loop)
+ if (expr && (gfc_is_class_array_function (expr)
|| gfc_is_alloc_class_scalar_function (expr))
&& se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
&& expr->must_finalize)
@@ -11977,6 +11992,28 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
old_vptr = build_int_cst (TREE_TYPE (vptr), 0);
size = gfc_vptr_size_get (rhs_vptr);
+
+ /* Take into account _len of unlimited polymorphic entities.
+ TODO: handle class(*) allocatable function results on rhs. */
+ if (UNLIMITED_POLY (rhs))
+ {
+ tree len;
+ if (rhs->expr_type == EXPR_VARIABLE)
+ len = trans_get_upoly_len (block, rhs);
+ else
+ len = gfc_class_len_get (tmp);
+ len = fold_build2_loc (input_location, MAX_EXPR, size_type_node,
+ fold_convert (size_type_node, len),
+ size_one_node);
+ size = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (size),
+ size, fold_convert (TREE_TYPE (size), len));
+ }
+ else if (rhs->ts.type == BT_CHARACTER && rse->string_length)
+ size = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_charlen_type_node, size,
+ rse->string_length);
+
+
tmp = lse->expr;
class_han = GFC_CLASS_TYPE_P (TREE_TYPE (tmp))
? gfc_class_data_get (tmp) : tmp;
@@ -11990,18 +12027,25 @@ trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs,
/* Reallocate if dynamic types are different. */
gfc_init_block (&re_alloc);
- tmp = fold_convert (pvoid_type_node, class_han);
- re = build_call_expr_loc (input_location,
- builtin_decl_explicit (BUILT_IN_REALLOC), 2,
- tmp, size);
- re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp), tmp,
- re);
- tmp = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node, rhs_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);
-
+ if (UNLIMITED_POLY (lhs) && rhs->ts.type == BT_CHARACTER)
+ {
+ gfc_add_expr_to_block (&re_alloc, gfc_call_free (class_han));
+ gfc_allocate_using_malloc (&re_alloc, class_han, size, NULL_TREE);
+ }
+ else
+ {
+ tmp = fold_convert (pvoid_type_node, class_han);
+ re = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_REALLOC),
+ 2, tmp, size);
+ re = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (tmp),
+ tmp, re);
+ tmp = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node, rhs_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);
+ }
tree realloc_expr = lhs->ts.type == BT_CLASS ?
gfc_finish_block (&re_alloc) :
build_empty_stmt (input_location);
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-16 02:13:44 +0000