aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran')
-rw-r--r--gcc/fortran/ChangeLog74
-rw-r--r--gcc/fortran/error.c2
-rw-r--r--gcc/fortran/frontend-passes.c31
-rw-r--r--gcc/fortran/gfortran.texi3
-rw-r--r--gcc/fortran/match.c20
-rw-r--r--gcc/fortran/resolve.c19
-rw-r--r--gcc/fortran/trans-expr.c125
-rw-r--r--gcc/fortran/trans-intrinsic.c26
-rw-r--r--gcc/fortran/trans-stmt.c14
9 files changed, 254 insertions, 60 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 88edff3eed6..04598438aae 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,71 @@
+2017-08-28 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/80477
+ * trans-expr.c (gfc_conv_procedure_call): Allocatable class
+ scalar results being passed to a derived type formal argument
+ are finalized if possible. Otherwise, rely on existing code for
+ deallocation. Make the deallocation of allocatable result
+ components conditional on finalization not taking place. Make
+ the freeing of data components after finalization conditional
+ on the data being NULL.
+ (gfc_trans_arrayfunc_assign): Change the gcc_assert to a
+ condition to return NULL_TREE.
+ (gfc_trans_assignment_1): If the assignment is class to class
+ and the rhs expression must be finalized but the assignment
+ is not marked as a polymorphic assignment, use the vptr copy
+ function instead of gfc_trans_scalar_assign.
+
+ PR fortran/86481
+ * trans-expr.c (gfc_conv_expr_reference): Do not add the post
+ block to the pre block if the expression is to be finalized.
+ * trans-stmt.c (gfc_trans_allocate): If the expr3 must be
+ finalized, load the post block into a finalization block and
+ add it right at the end of the allocation block.
+
+2018-08-27 David Malcolm <dmalcolm@redhat.com>
+
+ PR 87091
+ * error.c (gfc_format_decoder): Update for conversion of
+ show_caret_p to a tri-state.
+
+2018-08-25 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/86545
+ * resolve.c (resolve_transfer): Correctly determine typespec for
+ generic function calls, in order to throw a proper error.
+
+2018-08-24 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/86837
+ * frontend-passes.c (var_in_expr_callback): New function.
+ (var_in_expr): New function.
+ (traverse_io_block): Use var_in_expr instead of
+ gfc_check_dependency for checking if the variable depends on the
+ previous interators.
+
+2018-08-23 Janne Blomqvist <blomqvist.janne@gmail.com>
+
+ * trans-intrinsic.c (gfc_conv_intrinsic_minmaxval): Delete
+ HONOR_SIGNED_ZEROS checks.
+
+2018-08-23 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/86863
+ * resolve.c (resolve_typebound_call): If the TBP is not marked
+ as a subroutine, check the specific symbol.
+
+2018-08-22 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ * gfortran.texi: Mention that asynchronous I/O does
+ not work on systems which lack condition variables, such
+ as AIX.
+
+2018-08-22 Janus Weil <janus@gcc.gnu.org>
+
+ PR fortran/86935
+ * match.c (gfc_match_associate): Improve diagnostics for the ASSOCIATE
+ statement.
+
2018-08-22 Andrew Benson <abensonca@gmail.com>
* module.c (load_generic_interfaces): Move call to find_symbol()
@@ -903,7 +971,7 @@
* trans-intrinsic.c (conv_intrinsic_kill, conv_intrinsic_kill_sub): new
functions.
(gfc_conv_intrinsic_function): Use conv_intrinsic_kill.
- (gfc_conv_intrinsic_subroutine): Use conv_intrinsic_kill_sub.
+ (gfc_conv_intrinsic_subroutine): Use conv_intrinsic_kill_sub.
* trans.h: Declare gfor_fndecl_kill and gfor_fndecl_kill_sub.
2018-03-11 Paul Thomas <pault@gcc.gnu.org>
@@ -1138,7 +1206,7 @@
* trans-stmt.c (gfc_trans_lock_unlock): Likewise.
(gfc_trans_event_post_wait): Likewise.
(gfc_trans_sync): Likewise.
- (gfc_trans_stop): Use size_t for character lengths, int for exit
+ (gfc_trans_stop): Use size_t for character lengths, int for exit
codes.
2018-02-20 Thomas Koenig <tkoenig@gcc.gnu.org>
@@ -1759,7 +1827,7 @@
(gfc_interpret_character): Use gfc_charlen_t.
* target-memory.h (gfc_encode_character): Modify prototype.
* trans-array.c (gfc_trans_array_ctor_element): Use existing type.
- (get_array_ctor_var_strlen): Use gfc_conv_mpz_to_tree_type.
+ (get_array_ctor_var_strlen): Use gfc_conv_mpz_to_tree_type.
(trans_array_constructor): Use existing type.
(get_array_charlen): Likewise.
* trans-const.c (gfc_conv_mpz_to_tree_type): New function.
diff --git a/gcc/fortran/error.c b/gcc/fortran/error.c
index 7e882ba76bf..b3b0138b0c3 100644
--- a/gcc/fortran/error.c
+++ b/gcc/fortran/error.c
@@ -953,7 +953,7 @@ gfc_format_decoder (pretty_printer *pp, text_info *text, const char *spec,
= linemap_position_for_loc_and_offset (line_table,
loc->lb->location,
offset);
- text->set_location (loc_num, src_loc, true);
+ text->set_location (loc_num, src_loc, SHOW_RANGE_WITH_CARET);
pp_string (pp, result[loc_num]);
return true;
}
diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c
index f9dcddcb156..0a5e8937015 100644
--- a/gcc/fortran/frontend-passes.c
+++ b/gcc/fortran/frontend-passes.c
@@ -1104,6 +1104,31 @@ convert_elseif (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
return 0;
}
+/* Callback function to var_in_expr - return true if expr1 and
+ expr2 are identical variables. */
+static int
+var_in_expr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data)
+{
+ gfc_expr *expr1 = (gfc_expr *) data;
+ gfc_expr *expr2 = *e;
+
+ if (expr2->expr_type != EXPR_VARIABLE)
+ return 0;
+
+ return expr1->symtree->n.sym == expr2->symtree->n.sym;
+}
+
+/* Return true if expr1 is found in expr2. */
+
+static bool
+var_in_expr (gfc_expr *expr1, gfc_expr *expr2)
+{
+ gcc_assert (expr1->expr_type == EXPR_VARIABLE);
+
+ return gfc_expr_walker (&expr2, var_in_expr_callback, (void *) expr1);
+}
+
struct do_stack
{
struct do_stack *prev;
@@ -1256,9 +1281,9 @@ traverse_io_block (gfc_code *code, bool *has_reached, gfc_code *prev)
for (int j = i - 1; j < i; j++)
{
if (iters[j]
- && (gfc_check_dependency (var, iters[j]->start, true)
- || gfc_check_dependency (var, iters[j]->end, true)
- || gfc_check_dependency (var, iters[j]->step, true)))
+ && (var_in_expr (var, iters[j]->start)
+ || var_in_expr (var, iters[j]->end)
+ || var_in_expr (var, iters[j]->step)))
return false;
}
}
diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
index 0f3f454ff83..30934046a49 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -1509,7 +1509,8 @@ end program main
Asynchronous I/O is supported if the program is linked against the
POSIX thread library. If that is not the case, all I/O is performed
-as synchronous.
+as synchronous. On systems which do not support pthread condition
+variables, such as AIX, I/O is also performed as synchronous.
On some systems, such as Darwin or Solaris, the POSIX thread library
is always linked in, so asynchronous I/O is always performed. On other
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 1ab0e0fad9a..85247dd8334 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1889,17 +1889,21 @@ gfc_match_associate (void)
gfc_association_list* a;
/* Match the next association. */
- if (gfc_match (" %n => %e", newAssoc->name, &newAssoc->target)
- != MATCH_YES)
+ if (gfc_match (" %n =>", newAssoc->name) != MATCH_YES)
+ {
+ gfc_error ("Expected association at %C");
+ goto assocListError;
+ }
+
+ if (gfc_match (" %e", &newAssoc->target) != MATCH_YES)
{
/* Have another go, allowing for procedure pointer selectors. */
gfc_matching_procptr_assignment = 1;
- if (gfc_match (" %n => %e", newAssoc->name, &newAssoc->target)
- != MATCH_YES)
- {
- gfc_error ("Expected association at %C");
- goto assocListError;
- }
+ if (gfc_match (" %e", &newAssoc->target) != MATCH_YES)
+ {
+ gfc_error ("Invalid association target at %C");
+ goto assocListError;
+ }
gfc_matching_procptr_assignment = 0;
}
newAssoc->where = gfc_current_locus;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 4ad4dcf780d..ded27624283 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6266,9 +6266,17 @@ resolve_typebound_call (gfc_code* c, const char **name, bool *overridable)
/* Check that's really a SUBROUTINE. */
if (!c->expr1->value.compcall.tbp->subroutine)
{
- gfc_error ("%qs at %L should be a SUBROUTINE",
- c->expr1->value.compcall.name, &c->loc);
- return false;
+ if (!c->expr1->value.compcall.tbp->is_generic
+ && c->expr1->value.compcall.tbp->u.specific
+ && c->expr1->value.compcall.tbp->u.specific->n.sym
+ && c->expr1->value.compcall.tbp->u.specific->n.sym->attr.subroutine)
+ c->expr1->value.compcall.tbp->subroutine = 1;
+ else
+ {
+ gfc_error ("%qs at %L should be a SUBROUTINE",
+ c->expr1->value.compcall.name, &c->loc);
+ return false;
+ }
}
if (!check_typebound_baseobject (c->expr1))
@@ -9272,7 +9280,6 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns)
static void
resolve_transfer (gfc_code *code)
{
- gfc_typespec *ts;
gfc_symbol *sym, *derived;
gfc_ref *ref;
gfc_expr *exp;
@@ -9308,7 +9315,9 @@ resolve_transfer (gfc_code *code)
_("item in READ")))
return;
- ts = exp->expr_type == EXPR_STRUCTURE ? &exp->ts : &exp->symtree->n.sym->ts;
+ const gfc_typespec *ts = exp->expr_type == EXPR_STRUCTURE
+ || exp->expr_type == EXPR_FUNCTION
+ ? &exp->ts : &exp->symtree->n.sym->ts;
/* Go to actual component transferred. */
for (ref = exp->ref; ref; ref = ref->next)
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 54e318e21f7..56ce98c78c6 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -4886,6 +4886,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
for (arg = args, argc = 0; arg != NULL;
arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
{
+ bool finalized = false;
+
e = arg->expr;
fsym = formal ? formal->sym : NULL;
parm_kind = MISSING;
@@ -5360,7 +5362,42 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
&& e->ts.type == BT_CLASS
&& !CLASS_DATA (e)->attr.dimension
&& !CLASS_DATA (e)->attr.codimension)
- parmse.expr = gfc_class_data_get (parmse.expr);
+ {
+ parmse.expr = gfc_class_data_get (parmse.expr);
+ /* The result is a class temporary, whose _data component
+ must be freed to avoid a memory leak. */
+ if (e->expr_type == EXPR_FUNCTION
+ && CLASS_DATA (e)->attr.allocatable)
+ {
+ tree zero;
+
+ gfc_expr *var;
+
+ /* Borrow the function symbol to make a call to
+ gfc_add_finalizer_call and then restore it. */
+ tmp = e->symtree->n.sym->backend_decl;
+ e->symtree->n.sym->backend_decl
+ = TREE_OPERAND (parmse.expr, 0);
+ e->symtree->n.sym->attr.flavor = FL_VARIABLE;
+ var = gfc_lval_expr_from_sym (e->symtree->n.sym);
+ finalized = gfc_add_finalizer_call (&parmse.post,
+ var);
+ gfc_free_expr (var);
+ e->symtree->n.sym->backend_decl = tmp;
+ e->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+
+ /* Then free the class _data. */
+ zero = build_int_cst (TREE_TYPE (parmse.expr), 0);
+ tmp = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node,
+ parmse.expr, zero);
+ tmp = build3_v (COND_EXPR, tmp,
+ gfc_call_free (parmse.expr),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&parmse.post, tmp);
+ gfc_add_modify (&parmse.post, parmse.expr, zero);
+ }
+ }
/* Wrap scalar variable in a descriptor. We need to convert
the address of a pointer back to the pointer itself before,
@@ -5687,9 +5724,18 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
tmp = build_fold_indirect_ref_loc (input_location, tmp);
}
- tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp, parm_rank);
-
- gfc_prepend_expr_to_block (&post, tmp);
+ if (!finalized && !e->must_finalize)
+ {
+ if ((e->ts.type == BT_CLASS
+ && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+ || e->ts.type == BT_DERIVED)
+ tmp = gfc_deallocate_alloc_comp (e->ts.u.derived, tmp,
+ parm_rank);
+ else if (e->ts.type == BT_CLASS)
+ tmp = gfc_deallocate_alloc_comp (CLASS_DATA (e)->ts.u.derived,
+ tmp, parm_rank);
+ gfc_prepend_expr_to_block (&post, tmp);
+ }
}
/* Add argument checking of passing an unallocated/NULL actual to
@@ -6410,7 +6456,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
final_fndecl = gfc_class_vtab_final_get (se->expr);
is_final = fold_build2_loc (input_location, NE_EXPR,
logical_type_node,
- final_fndecl,
+ final_fndecl,
fold_convert (TREE_TYPE (final_fndecl),
null_pointer_node));
final_fndecl = build_fold_indirect_ref_loc (input_location,
@@ -6420,28 +6466,43 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_build_addr_expr (NULL, tmp),
gfc_class_vtab_size_get (se->expr),
boolean_false_node);
- tmp = fold_build3_loc (input_location, COND_EXPR,
+ tmp = fold_build3_loc (input_location, COND_EXPR,
void_type_node, is_final, tmp,
build_empty_stmt (input_location));
if (se->ss && se->ss->loop)
{
- gfc_add_expr_to_block (&se->ss->loop->post, tmp);
- tmp = gfc_call_free (info->data);
+ gfc_prepend_expr_to_block (&se->ss->loop->post, tmp);
+ tmp = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node,
+ info->data,
+ fold_convert (TREE_TYPE (info->data),
+ null_pointer_node));
+ tmp = fold_build3_loc (input_location, COND_EXPR,
+ void_type_node, tmp,
+ gfc_call_free (info->data),
+ build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->ss->loop->post, tmp);
}
else
{
- gfc_add_expr_to_block (&se->post, tmp);
- tmp = gfc_class_data_get (se->expr);
- tmp = gfc_call_free (tmp);
+ tree classdata;
+ gfc_prepend_expr_to_block (&se->post, tmp);
+ classdata = gfc_class_data_get (se->expr);
+ tmp = fold_build2_loc (input_location, NE_EXPR,
+ logical_type_node,
+ classdata,
+ fold_convert (TREE_TYPE (classdata),
+ null_pointer_node));
+ tmp = fold_build3_loc (input_location, COND_EXPR,
+ void_type_node, tmp,
+ gfc_call_free (classdata),
+ build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->post, tmp);
}
-
-no_finalization:
- expr->must_finalize = 0;
}
+no_finalization:
gfc_add_block_to_block (&se->post, &post);
}
@@ -8072,7 +8133,9 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr)
var = gfc_create_var (TREE_TYPE (se->expr), NULL);
gfc_add_modify (&se->pre, var, se->expr);
}
- gfc_add_block_to_block (&se->pre, &se->post);
+
+ if (!expr->must_finalize)
+ gfc_add_block_to_block (&se->pre, &se->post);
/* Take the address of that value. */
se->expr = gfc_build_addr_expr (NULL_TREE, var);
@@ -9262,10 +9325,12 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
/* The frontend doesn't seem to bother filling in expr->symtree for intrinsic
functions. */
comp = gfc_get_proc_ptr_comp (expr2);
- gcc_assert (expr2->value.function.isym
+
+ if (!(expr2->value.function.isym
|| (comp && comp->attr.dimension)
|| (!comp && gfc_return_by_reference (expr2->value.function.esym)
- && expr2->value.function.esym->result->attr.dimension));
+ && expr2->value.function.esym->result->attr.dimension)))
+ return NULL;
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
@@ -10238,6 +10303,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
gfc_add_block_to_block (&loop.post, &rse.post);
}
+ tmp = NULL_TREE;
+
if (is_poly_assign)
tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
use_vptr_copy || (lhs_attr.allocatable
@@ -10266,13 +10333,35 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
code.resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
tmp = gfc_conv_intrinsic_subroutine (&code);
}
- else
+ else if (!is_poly_assign && expr2->must_finalize
+ && expr1->ts.type == BT_CLASS
+ && expr2->ts.type == BT_CLASS)
+ {
+ /* 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 */
+ tmp = gfc_get_vptr_from_expr (rse.expr);
+ if (tmp != NULL_TREE)
+ {
+ tree fcn = gfc_vptr_copy_get (tmp);
+ if (POINTER_TYPE_P (TREE_TYPE (fcn)))
+ fcn = build_fold_indirect_ref_loc (input_location, fcn);
+ tmp = build_call_expr_loc (input_location,
+ fcn, 2,
+ gfc_build_addr_expr (NULL, rse.expr),
+ gfc_build_addr_expr (NULL, lse.expr));
+ }
+ }
+
+ /* If nothing else works, do it the old fashioned way! */
+ if (tmp == NULL_TREE)
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
gfc_expr_is_variable (expr2)
|| scalar_to_array
|| expr2->expr_type == EXPR_ARRAY,
!(l_is_temp || init_flag) && dealloc,
expr1->symtree->n.sym->attr.codimension);
+
/* Add the pre blocks to the body. */
gfc_add_block_to_block (&body, &rse.pre);
gfc_add_block_to_block (&body, &lse.pre);
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 387cf80b921..b2cea93742a 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -5511,22 +5511,10 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
{
/* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
signed zeros. */
- if (HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
- {
- tmp = fold_build2_loc (input_location, op, logical_type_node,
- arrayse.expr, limit);
- ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
- tmp = build3_v (COND_EXPR, tmp, ifbody,
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&block2, tmp);
- }
- else
- {
- tmp = fold_build2_loc (input_location,
- op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
- type, arrayse.expr, limit);
- gfc_add_modify (&block2, limit, tmp);
- }
+ tmp = fold_build2_loc (input_location,
+ op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
+ type, arrayse.expr, limit);
+ gfc_add_modify (&block2, limit, tmp);
}
if (fast)
@@ -5535,8 +5523,7 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
/* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
signed zeros. */
- if (HONOR_NANS (DECL_MODE (limit))
- || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
+ if (HONOR_NANS (DECL_MODE (limit)))
{
tmp = fold_build2_loc (input_location, op, logical_type_node,
arrayse.expr, limit);
@@ -5598,8 +5585,7 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
/* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
signed zeros. */
- if (HONOR_NANS (DECL_MODE (limit))
- || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
+ if (HONOR_NANS (DECL_MODE (limit)))
{
tmp = fold_build2_loc (input_location, op, logical_type_node,
arrayse.expr, limit);
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index cc1a4294327..795d3cc0a13 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5783,6 +5783,7 @@ gfc_trans_allocate (gfc_code * code)
enum { E3_UNSET = 0, E3_SOURCE, E3_MOLD, E3_DESC } e3_is;
stmtblock_t block;
stmtblock_t post;
+ stmtblock_t final_block;
tree nelems;
bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set, is_coarray;
bool needs_caf_sync, caf_refs_comp;
@@ -5801,6 +5802,7 @@ gfc_trans_allocate (gfc_code * code)
gfc_init_block (&block);
gfc_init_block (&post);
+ gfc_init_block (&final_block);
/* STAT= (and maybe ERRMSG=) is present. */
if (code->expr1)
@@ -5842,6 +5844,11 @@ gfc_trans_allocate (gfc_code * code)
is_coarray = gfc_is_coarray (code->expr3);
+ if (code->expr3->expr_type == EXPR_FUNCTION && !code->expr3->mold
+ && (gfc_is_class_array_function (code->expr3)
+ || gfc_is_alloc_class_scalar_function (code->expr3)))
+ code->expr3->must_finalize = 1;
+
/* Figure whether we need the vtab from expr3. */
for (al = code->ext.alloc.list; !vtab_needed && al != NULL;
al = al->next)
@@ -5914,7 +5921,10 @@ gfc_trans_allocate (gfc_code * code)
temp_obj_created = temp_var_needed = !VAR_P (se.expr);
}
gfc_add_block_to_block (&block, &se.pre);
- gfc_add_block_to_block (&post, &se.post);
+ if (code->expr3->must_finalize)
+ gfc_add_block_to_block (&final_block, &se.post);
+ else
+ gfc_add_block_to_block (&post, &se.post);
/* Special case when string in expr3 is zero. */
if (code->expr3->ts.type == BT_CHARACTER
@@ -6743,6 +6753,8 @@ gfc_trans_allocate (gfc_code * code)
gfc_add_block_to_block (&block, &se.post);
gfc_add_block_to_block (&block, &post);
+ if (code->expr3 && code->expr3->must_finalize)
+ gfc_add_block_to_block (&block, &final_block);
return gfc_finish_block (&block);
}
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-29 10:10:05 +0000