summaryrefslogtreecommitdiff
path: root/gcc/fortran/trans-array.c
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran/trans-array.c')
-rw-r--r--gcc/fortran/trans-array.c64
1 files changed, 34 insertions, 30 deletions
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 6cb85d48311..89f26d7d976 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -300,7 +300,11 @@ gfc_conv_descriptor_token (tree desc)
gcc_assert (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE);
gcc_assert (gfc_option.coarray == GFC_FCOARRAY_LIB);
field = gfc_advance_chain (TYPE_FIELDS (type), CAF_TOKEN_FIELD);
- gcc_assert (field != NULL_TREE && TREE_TYPE (field) == prvoid_type_node);
+
+ /* Should be a restricted pointer - except in the finalization wrapper. */
+ gcc_assert (field != NULL_TREE
+ && (TREE_TYPE (field) == prvoid_type_node
+ || TREE_TYPE (field) == pvoid_type_node));
return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
desc, field, NULL_TREE);
@@ -4830,7 +4834,8 @@ static tree
gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
stmtblock_t * descriptor_block, tree * overflow,
- tree expr3_elem_size, tree *nelems, gfc_expr *expr3)
+ tree expr3_elem_size, tree *nelems, gfc_expr *expr3,
+ gfc_typespec *ts)
{
tree type;
tree tmp;
@@ -5008,6 +5013,9 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
tmp = TYPE_SIZE_UNIT (tmp);
}
}
+ else if (ts->type != BT_UNKNOWN && ts->type != BT_CHARACTER)
+ /* FIXME: Properly handle characters. See PR 57456. */
+ tmp = TYPE_SIZE_UNIT (gfc_typenode_for_spec (ts));
else
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
@@ -5077,7 +5085,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
bool
gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
tree errlen, tree label_finish, tree expr3_elem_size,
- tree *nelems, gfc_expr *expr3)
+ tree *nelems, gfc_expr *expr3, gfc_typespec *ts)
{
tree tmp;
tree pointer;
@@ -5162,7 +5170,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
ref->u.ar.as->corank, &offset, lower, upper,
&se->pre, &set_descriptor_block, &overflow,
- expr3_elem_size, nelems, expr3);
+ expr3_elem_size, nelems, expr3, ts);
if (dimension)
{
@@ -5222,18 +5230,6 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
gfc_add_expr_to_block (&se->pre, tmp);
- if (expr->ts.type == BT_CLASS)
- {
- tmp = build_int_cst (unsigned_char_type_node, 0);
- /* With class objects, it is best to play safe and null the
- memory because we cannot know if dynamic types have allocatable
- components or not. */
- tmp = build_call_expr_loc (input_location,
- builtin_decl_explicit (BUILT_IN_MEMSET),
- 3, pointer, tmp, size);
- gfc_add_expr_to_block (&se->pre, tmp);
- }
-
/* Update the array descriptors. */
if (dimension)
gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset);
@@ -7251,7 +7247,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77,
/* Generate code to deallocate an array, if it is allocated. */
tree
-gfc_trans_dealloc_allocated (tree descriptor, bool coarray)
+gfc_trans_dealloc_allocated (tree descriptor, bool coarray, gfc_expr *expr)
{
tree tmp;
tree var;
@@ -7267,7 +7263,7 @@ gfc_trans_dealloc_allocated (tree descriptor, bool coarray)
are already deallocated are ignored. */
tmp = gfc_deallocate_with_status (coarray ? descriptor : var, NULL_TREE,
NULL_TREE, NULL_TREE, NULL_TREE, true,
- NULL, coarray);
+ expr, coarray);
gfc_add_expr_to_block (&block, tmp);
/* Zero the data pointer. */
@@ -7556,7 +7552,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
{
comp = fold_build3_loc (input_location, COMPONENT_REF, ctype,
decl, cdecl, NULL_TREE);
- tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension);
+ tmp = gfc_trans_dealloc_allocated (comp, c->attr.codimension, NULL);
gfc_add_expr_to_block (&tmpblock, tmp);
}
else if (c->attr.allocatable)
@@ -7588,7 +7584,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
tmp = gfc_trans_dealloc_allocated (comp,
- CLASS_DATA (c)->attr.codimension);
+ CLASS_DATA (c)->attr.codimension, NULL);
else
{
tmp = gfc_deallocate_scalar_with_status (comp, NULL_TREE, true, NULL,
@@ -7699,6 +7695,10 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
{
nelems = gfc_conv_descriptor_size (src_data,
CLASS_DATA (c)->as->rank);
+ size = fold_build2_loc (input_location, MULT_EXPR,
+ size_type_node, size,
+ fold_convert (size_type_node,
+ nelems));
src_data = gfc_conv_descriptor_data_get (src_data);
dst_data = gfc_conv_descriptor_data_get (dst_data);
}
@@ -7707,11 +7707,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
gfc_init_block (&tmpblock);
- /* We need to use CALLOC as _copy might try to free allocatable
- components of the destination. */
- ftn_tree = builtin_decl_explicit (BUILT_IN_CALLOC);
- tmp = build_call_expr_loc (input_location, ftn_tree, 2, nelems,
- size);
+ ftn_tree = builtin_decl_explicit (BUILT_IN_MALLOC);
+ tmp = build_call_expr_loc (input_location, ftn_tree, 1, size);
gfc_add_modify (&tmpblock, dst_data,
fold_convert (TREE_TYPE (dst_data), tmp));
@@ -8299,7 +8296,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
stmtblock_t cleanup;
locus loc;
int rank;
- bool sym_has_alloc_comp;
+ bool sym_has_alloc_comp, has_finalizer;
sym_has_alloc_comp = (sym->ts.type == BT_DERIVED
|| sym->ts.type == BT_CLASS)
@@ -8386,8 +8383,12 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
/* Allocatable arrays need to be freed when they go out of scope.
The allocatable components of pointers must not be touched. */
- if (sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
- && !sym->attr.pointer && !sym->attr.save)
+ has_finalizer = sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED
+ ? gfc_is_finalizable (sym->ts.u.derived, NULL) : false;
+ if ((!sym->attr.allocatable || !has_finalizer)
+ && sym_has_alloc_comp && !(sym->attr.function || sym->attr.result)
+ && !sym->attr.pointer && !sym->attr.save
+ && !sym->ns->proc_name->attr.is_main_program)
{
int rank;
rank = sym->as ? sym->as->rank : 0;
@@ -8396,10 +8397,13 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
}
if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
- && !sym->attr.save && !sym->attr.result)
+ && !sym->attr.save && !sym->attr.result
+ && !sym->ns->proc_name->attr.is_main_program)
{
tmp = gfc_trans_dealloc_allocated (sym->backend_decl,
- sym->attr.codimension);
+ sym->attr.codimension,
+ has_finalizer
+ ? gfc_lval_expr_from_sym (sym) : NULL);
gfc_add_expr_to_block (&cleanup, tmp);
}
View Lorry Controller Status