diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 44177aa0813..0b312f807df 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -994,9 +994,9 @@ gfc_get_array_span (tree desc, gfc_expr *expr) if (tmp && TREE_CODE (tmp) == ARRAY_TYPE && TYPE_STRING_FLAG (tmp)) { gcc_assert (expr->ts.type == BT_CHARACTER); - + tmp = gfc_get_character_len_in_bytes (tmp); - + if (tmp == NULL_TREE || integer_zerop (tmp)) { tree bs; @@ -1007,7 +1007,7 @@ gfc_get_array_span (tree desc, gfc_expr *expr) tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, tmp, bs); } - + tmp = (tmp && !integer_zerop (tmp)) ? (fold_convert (gfc_array_index_type, tmp)) : (NULL_TREE); } @@ -2026,10 +2026,11 @@ gfc_trans_array_constructor_subarray (stmtblock_t * pblock, for the dynamic parts must be allocated using realloc. */ static void -gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, - tree desc, gfc_constructor_base base, - tree * poffset, tree * offsetvar, - bool dynamic) +gfc_trans_array_constructor_value (stmtblock_t * pblock, + stmtblock_t * finalblock, + tree type, tree desc, + gfc_constructor_base base, tree * poffset, + tree * offsetvar, bool dynamic) { tree tmp; tree start = NULL_TREE; @@ -2039,6 +2040,8 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, gfc_se se; mpz_t size; gfc_constructor *c; + gfc_typespec ts; + int ctr = 0; tree shadow_loopvar = NULL_TREE; gfc_saved_var saved_loopvar; @@ -2046,6 +2049,7 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, mpz_init (size); for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) { + ctr++; /* If this is an iterator or an array, the offset must be a variable. */ if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset)) gfc_put_offset_into_var (pblock, poffset, offsetvar); @@ -2091,8 +2095,8 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, if (c->expr->expr_type == EXPR_ARRAY) { /* Array constructors can be nested. */ - gfc_trans_array_constructor_value (&body, type, desc, - c->expr->value.constructor, + gfc_trans_array_constructor_value (&body, finalblock, type, + desc, c->expr->value.constructor, poffset, offsetvar, dynamic); } else if (c->expr->rank > 0) @@ -2200,6 +2204,7 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, gfc_add_modify (&body, *offsetvar, *poffset); *poffset = *offsetvar; } + ts = c->expr->ts; } /* The frontend should already have done any expansions @@ -2292,6 +2297,34 @@ gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type, gfc_restore_sym (c->iterator->var->symtree->n.sym, &saved_loopvar); } } + + /* F2008 4.5.6.3 para 5: If an executable construct references a structure + constructor or array constructor, the entity created by the constructor is + finalized after execution of the innermost executable construct containing + the reference. This, in fact, was later deleted by the Combined Techical + Corrigenda 1 TO 4 for fortran 2008 (f08/0011). + + Transmit finalization of this constructor through 'finalblock'. */ + if (!gfc_notification_std (GFC_STD_F2018_DEL) && finalblock != NULL + && gfc_may_be_finalized (ts) + && ctr > 0 && desc != NULL_TREE + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) + { + symbol_attribute attr; + gfc_se fse; + gfc_warning (0, "The structure constructor at %C has been" + " finalized. This feature was removed by f08/0011." + " Use -std=f2018 or -std=gnu to eliminate the" + " finalization."); + attr.pointer = attr.allocatable = 0; + gfc_init_se (&fse, NULL); + fse.expr = desc; + gfc_finalize_function_result (&fse, ts.u.derived, attr, 1); + gfc_add_block_to_block (finalblock, &fse.pre); + gfc_add_block_to_block (finalblock, &fse.finalblock); + gfc_add_block_to_block (finalblock, &fse.post); + } + mpz_clear (size); } @@ -2738,6 +2771,7 @@ trans_array_constructor (gfc_ss * ss, locus * where) gfc_ss *s; tree neg_len; char *msg; + stmtblock_t finalblock; /* Save the old values for nested checking. */ old_first_len = first_len; @@ -2897,8 +2931,12 @@ trans_array_constructor (gfc_ss * ss, locus * where) offsetvar = gfc_create_var_np (gfc_array_index_type, "offset"); suppress_warning (offsetvar); TREE_USED (offsetvar) = 0; - gfc_trans_array_constructor_value (&outer_loop->pre, type, desc, c, - &offset, &offsetvar, dynamic); + + gfc_init_block (&finalblock); + gfc_trans_array_constructor_value (&outer_loop->pre, + expr->must_finalize ? &finalblock : NULL, + type, desc, c, &offset, &offsetvar, + dynamic); /* If the array grows dynamically, the upper bound of the loop variable is determined by the array's final upper bound. */ @@ -2933,6 +2971,15 @@ finish: first_len = old_first_len; first_len_val = old_first_len_val; typespec_chararray_ctor = old_typespec_chararray_ctor; + + /* F2008 4.5.6.3 para 5: If an executable construct references a structure + constructor or array constructor, the entity created by the constructor is + finalized after execution of the innermost executable construct containing + the reference. */ + if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS) + && finalblock.head != NULL_TREE) + gfc_add_block_to_block (&loop->post, &finalblock); + } @@ -3161,6 +3208,7 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, gfc_conv_expr (&se, expr); gfc_add_block_to_block (&outer_loop->pre, &se.pre); gfc_add_block_to_block (&outer_loop->post, &se.post); + gfc_add_block_to_block (&outer_loop->post, &se.finalblock); ss_info->string_length = se.string_length; break; @@ -6457,20 +6505,22 @@ gfc_trans_array_cobounds (tree type, stmtblock_t * pblock, /* Evaluate non-constant array bound expressions. */ lbound = GFC_TYPE_ARRAY_LBOUND (type, dim); if (as->lower[dim] && !INTEGER_CST_P (lbound)) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - gfc_add_modify (pblock, lbound, se.expr); - } + { + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type); + gfc_add_block_to_block (pblock, &se.pre); + gfc_add_block_to_block (pblock, &se.finalblock); + gfc_add_modify (pblock, lbound, se.expr); + } ubound = GFC_TYPE_ARRAY_UBOUND (type, dim); if (as->upper[dim] && !INTEGER_CST_P (ubound)) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - gfc_add_modify (pblock, ubound, se.expr); - } + { + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type); + gfc_add_block_to_block (pblock, &se.pre); + gfc_add_block_to_block (pblock, &se.finalblock); + gfc_add_modify (pblock, ubound, se.expr); + } } } @@ -6502,20 +6552,22 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset, /* Evaluate non-constant array bound expressions. */ lbound = GFC_TYPE_ARRAY_LBOUND (type, dim); if (as->lower[dim] && !INTEGER_CST_P (lbound)) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - gfc_add_modify (pblock, lbound, se.expr); - } + { + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, as->lower[dim], gfc_array_index_type); + gfc_add_block_to_block (pblock, &se.pre); + gfc_add_block_to_block (pblock, &se.finalblock); + gfc_add_modify (pblock, lbound, se.expr); + } ubound = GFC_TYPE_ARRAY_UBOUND (type, dim); if (as->upper[dim] && !INTEGER_CST_P (ubound)) - { - gfc_init_se (&se, NULL); - gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type); - gfc_add_block_to_block (pblock, &se.pre); - gfc_add_modify (pblock, ubound, se.expr); - } + { + gfc_init_se (&se, NULL); + gfc_conv_expr_type (&se, as->upper[dim], gfc_array_index_type); + gfc_add_block_to_block (pblock, &se.pre); + gfc_add_block_to_block (pblock, &se.finalblock); + gfc_add_modify (pblock, ubound, se.expr); + } /* The offset of this dimension. offset = offset - lbound * stride. */ tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, lbound, size); @@ -6529,19 +6581,19 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset, stride = GFC_TYPE_ARRAY_SIZE (type); if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride))) - { - /* Calculate stride = size * (ubound + 1 - lbound). */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, + { + /* Calculate stride = size * (ubound + 1 - lbound). */ + tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, gfc_index_one_node, lbound); - tmp = fold_build2_loc (input_location, PLUS_EXPR, + tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, ubound, tmp); - tmp = fold_build2_loc (input_location, MULT_EXPR, + tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, size, tmp); - if (stride) - gfc_add_modify (pblock, stride, tmp); - else - stride = gfc_evaluate_now (tmp, pblock); + if (stride) + gfc_add_modify (pblock, stride, tmp); + else + stride = gfc_evaluate_now (tmp, pblock); /* Make sure that negative size arrays are translated to being zero size. */ @@ -6551,7 +6603,7 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset, gfc_array_index_type, tmp, stride, gfc_index_zero_node); gfc_add_modify (pblock, stride, tmp); - } + } size = stride; } @@ -7531,7 +7583,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) if (!se->direct_byref) se->unlimited_polymorphic = UNLIMITED_POLY (expr); - + /* Special case things we know we can pass easily. */ switch (expr->expr_type) { @@ -8973,9 +9025,11 @@ enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, static gfc_actual_arglist *pdt_param_list; static tree -structure_alloc_comps (gfc_symbol * der_type, tree decl, - tree dest, int rank, int purpose, int caf_mode, - gfc_co_subroutines_args *args) +structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, + int rank, int purpose, int caf_mode, + gfc_co_subroutines_args *args, + bool no_finalization = false, + bool del_ptrs = false) { gfc_component *c; gfc_loopinfo loop; @@ -9063,11 +9117,12 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_conv_array_data (dest)); dref = gfc_build_array_ref (tmp, index, NULL); tmp = structure_alloc_comps (der_type, vref, dref, rank, - COPY_ALLOC_COMP, caf_mode, args); + COPY_ALLOC_COMP, caf_mode, args, + no_finalization); } else tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose, - caf_mode, args); + caf_mode, args, no_finalization); gfc_add_expr_to_block (&loopbody, tmp); @@ -9101,13 +9156,15 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, if (purpose == DEALLOCATE_ALLOC_COMP && der_type->attr.pdt_type) { tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank, - DEALLOCATE_PDT_COMP, 0, args); + DEALLOCATE_PDT_COMP, 0, args, + no_finalization); gfc_add_expr_to_block (&fnblock, tmp); } else if (purpose == ALLOCATE_PDT_COMP && der_type->attr.alloc_comp) { tmp = structure_alloc_comps (der_type, decl, NULL_TREE, rank, - NULLIFY_ALLOC_COMP, 0, args); + NULLIFY_ALLOC_COMP, 0, args, + no_finalization); gfc_add_expr_to_block (&fnblock, tmp); } @@ -9169,7 +9226,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, add_when_allocated = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived, comp, NULL_TREE, rank, purpose, - caf_mode, args); + caf_mode, args, no_finalization); } else { @@ -9177,7 +9234,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, add_when_allocated = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE, rank, purpose, - caf_mode, args); + caf_mode, args, + no_finalization); } } @@ -9293,8 +9351,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, continue; } - if ((c->ts.type == BT_DERIVED && !c->attr.pointer) - || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer)) + if (!no_finalization && ((c->ts.type == BT_DERIVED && !c->attr.pointer) + || (c->ts.type == BT_CLASS && !CLASS_DATA (c)->attr.class_pointer))) /* Call the finalizer, which will free the memory and nullify the pointer of an array. */ deallocate_called = gfc_add_comp_finalizer_call (&tmpblock, comp, c, @@ -9322,7 +9380,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, add_when_allocated = structure_alloc_comps (CLASS_DATA (c)->ts.u.derived, comp, NULL_TREE, rank, purpose, - caf_mode, args); + caf_mode, args, no_finalization); } else { @@ -9330,7 +9388,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, add_when_allocated = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE, rank, purpose, - caf_mode, args); + caf_mode, args, + no_finalization); } } @@ -9628,7 +9687,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, decl, cdecl, NULL_TREE); rank = c->as ? c->as->rank : 0; tmp = structure_alloc_comps (c->ts.u.derived, comp, NULL_TREE, - rank, purpose, caf_mode, args); + rank, purpose, caf_mode, args, + no_finalization); gfc_add_expr_to_block (&fnblock, tmp); } break; @@ -9664,14 +9724,14 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp, rank, purpose, caf_mode | GFC_STRUCTURE_CAF_MODE_IN_COARRAY, - args); + args, no_finalization); gfc_add_expr_to_block (&fnblock, tmp); } } break; case COPY_ALLOC_COMP: - if (c->attr.pointer || c->attr.proc_pointer) + if ((c->attr.pointer && !del_ptrs) || c->attr.proc_pointer) continue; /* We need source and destination components. */ @@ -9713,6 +9773,13 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, dst_data = gfc_conv_descriptor_data_get (dst_data); } + if (CLASS_DATA (c)->attr.pointer) + { + gfc_add_modify (&fnblock, dst_data, + build_int_cst (TREE_TYPE (dst_data), 0)); + continue; + } + gfc_init_block (&tmpblock); gfc_add_modify (&tmpblock, gfc_class_vptr_get (dcmp), @@ -9759,6 +9826,16 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tmp, null_data)); continue; } + else if (c->attr.pointer) + { + if (c->attr.dimension) + tmp = gfc_conv_descriptor_data_get (dcmp); + else + tmp = dcmp; + gfc_add_modify (&fnblock, tmp, + build_int_cst (TREE_TYPE (tmp), 0)); + continue; + } /* To implement guarded deep copy, i.e., deep copy only allocatable components that are really allocated, the deep copy code has to @@ -9772,7 +9849,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, add_when_allocated = structure_alloc_comps (c->ts.u.derived, comp, dcmp, rank, purpose, - caf_mode, args); + caf_mode, args, + no_finalization); } else add_when_allocated = NULL_TREE; @@ -10145,7 +10223,8 @@ gfc_nullify_alloc_comp (gfc_symbol * der_type, tree decl, int rank, { return structure_alloc_comps (der_type, decl, NULL_TREE, rank, NULLIFY_ALLOC_COMP, - GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL); + GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, + NULL); } @@ -10158,7 +10237,8 @@ gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank, { return structure_alloc_comps (der_type, decl, NULL_TREE, rank, DEALLOCATE_ALLOC_COMP, - GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, NULL); + GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY | caf_mode, + NULL); } tree @@ -10196,7 +10276,8 @@ gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank, tmp = structure_alloc_comps (derived, array, NULL_TREE, rank, BCAST_ALLOC_COMP, - GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, &args); + GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, + &args); return tmp; } @@ -10206,10 +10287,12 @@ gfc_bcast_alloc_comp (gfc_symbol *derived, gfc_expr *expr, int rank, status of coarrays. */ tree -gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank) +gfc_deallocate_alloc_comp_no_caf (gfc_symbol * der_type, tree decl, int rank, + bool no_finalization) { return structure_alloc_comps (der_type, decl, NULL_TREE, rank, - DEALLOCATE_ALLOC_COMP, 0, NULL); + DEALLOCATE_ALLOC_COMP, 0, NULL, + no_finalization); } @@ -10217,7 +10300,8 @@ tree gfc_reassign_alloc_comp_caf (gfc_symbol *der_type, tree decl, tree dest) { return structure_alloc_comps (der_type, decl, dest, 0, REASSIGN_CAF_COMP, - GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, NULL); + GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY, + NULL); } @@ -10233,6 +10317,20 @@ gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank, } +/* Recursively traverse an object of derived type, generating code to + copy it and its allocatable components, while suppressing any + finalization that might occur. This is used in the finalization of + function results. */ + +tree +gfc_copy_alloc_comp_del_ptrs (gfc_symbol * der_type, tree decl, tree dest, + int rank, int caf_mode) +{ + return structure_alloc_comps (der_type, decl, dest, rank, COPY_ALLOC_COMP, + caf_mode, NULL, true, true); +} + + /* Recursively traverse an object of derived type, generating code to copy only its allocatable components. */ @@ -10972,7 +11070,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, && expr1->ts.u.derived->attr.alloc_comp) { tmp = gfc_deallocate_alloc_comp_no_caf (expr1->ts.u.derived, old_desc, - expr1->rank); + expr1->rank, true); gfc_add_expr_to_block (&realloc_block, tmp); } @@ -11145,8 +11243,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block) sym_has_alloc_comp = (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) && sym->ts.u.derived->attr.alloc_comp; - has_finalizer = sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED - ? gfc_is_finalizable (sym->ts.u.derived, NULL) : false; + has_finalizer = gfc_may_be_finalized (sym->ts); /* Make sure the frontend gets these right. */ gcc_assert (sym->attr.pointer || sym->attr.allocatable || sym_has_alloc_comp