https://gcc.gnu.org/g:749d4907fa5321f6283899865cbe6ea4094979d4
commit 749d4907fa5321f6283899865cbe6ea4094979d4 Author: Mikael Morin <mik...@gcc.gnu.org> Date: Wed Jul 2 11:30:20 2025 +0200 Revert "Fortran: Suppress bogus used uninitialized warnings [PR108889]." This reverts commit c3aa339ea50f050caf7ed2e497f5499ec2d7b9cc. Sauvegarde suppression initialisation inutile bornes pour taire warnings Correction régression realloc_on_assign_23.f90 Correction régression realloc_on_assign_1.f03 Correction régression pr108889.f90 realloc_on_assign* Correction régression associate_46.f90 Correction régression array_function_6.f90 Correction régression allocate_with_source_5.f90 Correction régression func_result_6.f90 Correction régression PR95196.f90 Correction typebound_operator_9.f90 Correction régression class_transformational_2.f90 Correction régression alloc_comp_assign_12 etc Correction actual_array_offset_1.f90 Diff: --- gcc/fortran/gfortran.h | 4 - gcc/fortran/resolve.cc | 46 ++++++++-- gcc/fortran/trans-array.cc | 203 ++++++++++++++++++++++++++++++--------------- gcc/fortran/trans-expr.cc | 34 ++++---- 4 files changed, 190 insertions(+), 97 deletions(-) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 6848bd1762d3..69367e638c5b 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2028,10 +2028,6 @@ typedef struct gfc_symbol /* Set if this should be passed by value, but is not a VALUE argument according to the Fortran standard. */ unsigned pass_as_value:1; - /* Set if an allocatable array variable has been allocated in the current - scope. Used in the suppression of uninitialized warnings in reallocation - on assignment. */ - unsigned allocated_in_scope:1; /* Set if an external dummy argument is called with different argument lists. This is legal in Fortran, but can cause problems with autogenerated C prototypes for C23. */ diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 4a6e951cdf16..5b021ad6137b 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -2800,6 +2800,31 @@ done: } +static void +expression_shape (gfc_expr *e, gfc_array_spec *as) +{ + mpz_t array[GFC_MAX_DIMENSIONS]; + int i; + + if (e->rank <= 0 || e->shape != NULL) + return; + + for (i = 0; i < e->rank; i++) + if (!spec_dimen_size (as, i, &array[i])) + goto fail; + + e->shape = gfc_get_shape (e->rank); + + memcpy (e->shape, array, e->rank * sizeof (mpz_t)); + + return; + +fail: + for (i--; i >= 0; i--) + mpz_clear (array[i]); +} + + /************* Function resolution *************/ /* Resolve a function call known to be generic. @@ -2823,15 +2848,17 @@ resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym) else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN) expr->ts = s->result->ts; - if (s->as != NULL) - { - expr->rank = s->as->rank; - expr->corank = s->as->corank; - } - else if (s->result != NULL && s->result->as != NULL) + if (s->result != NULL && s->result->as != NULL) { expr->rank = s->result->as->rank; expr->corank = s->result->as->corank; + expression_shape (expr, s->result->as); + } + else if (s->as != NULL) + { + expr->rank = s->as->rank; + expr->corank = s->as->corank; + expression_shape (expr, s->as); } gfc_set_sym_referenced (expr->value.function.esym); @@ -2975,11 +3002,13 @@ found: { expr->rank = CLASS_DATA (sym)->as->rank; expr->corank = CLASS_DATA (sym)->as->corank; + expression_shape (expr, CLASS_DATA (sym)->as); } else if (sym->as != NULL) { expr->rank = sym->as->rank; expr->corank = sym->as->corank; + expression_shape (expr, sym->as); } return MATCH_YES; @@ -3104,6 +3133,7 @@ resolve_unknown_f (gfc_expr *expr) { expr->rank = sym->as->rank; expr->corank = sym->as->corank; + expression_shape (expr, sym->as); } /* Type of the expression is either the type of the symbol or the @@ -3663,6 +3693,7 @@ resolve_function (gfc_expr *expr) gfc_warning (OPT_Wdeprecated_declarations, "Using function %qs at %L is deprecated", sym->name, &expr->where); + return t; } @@ -5896,9 +5927,6 @@ gfc_resolve_ref (gfc_expr *expr) } -/* Given an expression, determine its shape. This is easier than it sounds. - Leaves the shape array NULL if it is not possible to determine the shape. */ - static void expression_shape (gfc_expr *e) { diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 7be2d7b11a62..76939bdf7ef9 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -3420,6 +3420,35 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, } +/* A simple reference can be accessed with a pointer and + a constant offset. */ +bool +simple_reference_p (tree data_ref) +{ + bool seen_dereference = false; + while (true) + { + if (DECL_P (data_ref)) + return true; + + if (TREE_CODE (data_ref) == INDIRECT_REF) + { + if (seen_dereference) + return false; + + seen_dereference = true; + data_ref = TREE_OPERAND (data_ref, 0); + } + else if (TREE_CODE (data_ref) == COMPONENT_REF) + data_ref = TREE_OPERAND (data_ref, 0); + else if (TREE_CODE (data_ref) == NOP_EXPR) + data_ref = TREE_OPERAND (data_ref, 0); + else + return false; + } +} + + /* Translate expressions for the descriptor and data pointer of a SS. */ /*GCC ARRAYS*/ @@ -3440,7 +3469,35 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base) se.descriptor_only = 1; gfc_conv_expr_lhs (&se, ss_info->expr); gfc_add_block_to_block (block, &se.pre); - info->descriptor = se.expr; + if (simple_reference_p (se.expr)) + info->descriptor = se.expr; + else + { + tree desc = se.expr; + STRIP_NOPS (desc); + if (TREE_CODE (desc) == INDIRECT_REF) + { + tree ptr = TREE_OPERAND (desc, 0); + ptr = gfc_evaluate_now (ptr, block); + TREE_OPERAND (desc, 0) = ptr; + info->descriptor = se.expr; + } + else if (TREE_CODE (desc) == COMPONENT_REF) + { + tree parent_ref = TREE_OPERAND (desc, 0); + tree parent_ptr_type = build_pointer_type (TREE_TYPE (parent_ref)); + tree ptr = fold_build1_loc (input_location, ADDR_EXPR, + parent_ptr_type, parent_ref); + ptr = gfc_evaluate_now (ptr, block); + tree deref = fold_build1_loc (input_location, INDIRECT_REF, + TREE_TYPE (parent_ref), + ptr); + TREE_OPERAND (desc, 0) = deref; + info->descriptor = se.expr; + } + else + info->descriptor = gfc_evaluate_now (se.expr, block); + } ss_info->string_length = se.string_length; ss_info->class_container = se.class_container; @@ -3471,12 +3528,15 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base) && DECL_P (TREE_OPERAND (tmp, 0))) || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) && TREE_CODE (se.expr) == COMPONENT_REF - && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (se.expr, 0)))))) + && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (se.expr, 0))))) + && !ss->is_alloc_lhs) tmp = gfc_evaluate_now (tmp, block); info->data = tmp; tmp = gfc_conv_array_offset (se.expr); - info->offset = gfc_evaluate_now (tmp, block); + if (!ss->is_alloc_lhs) + tmp = gfc_evaluate_now (tmp, block); + info->offset = tmp; /* Make absolutely sure that the saved_offset is indeed saved so that the variable is still accessible after the loops @@ -4769,13 +4829,12 @@ gfc_trans_scalarized_loop_boundary (gfc_loopinfo * loop, stmtblock_t * body) static void evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values, - tree desc, int dim, bool lbound, bool deferred) + tree desc, int dim, bool lbound, bool deferred, bool save_value) { gfc_se se; gfc_expr * input_val = values[dim]; tree *output = &bounds[dim]; - if (input_val) { /* Specified section bound. */ @@ -4801,7 +4860,8 @@ evaluate_bound (stmtblock_t *block, tree *bounds, gfc_expr ** values, *output = lbound ? gfc_conv_array_lbound (desc, dim) : gfc_conv_array_ubound (desc, dim); } - *output = gfc_evaluate_now (*output, block); + if (save_value) + *output = gfc_evaluate_now (*output, block); } @@ -4834,18 +4894,18 @@ gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim) || ar->dimen_type[dim] == DIMEN_THIS_IMAGE); desc = info->descriptor; stride = ar->stride[dim]; - + bool save_value = !ss->is_alloc_lhs; /* Calculate the start of the range. For vector subscripts this will be the range of the vector. */ evaluate_bound (block, info->start, ar->start, desc, dim, true, - ar->as->type == AS_DEFERRED); + ar->as->type == AS_DEFERRED, save_value); /* Similarly calculate the end. Although this is not used in the scalarizer, it is needed when checking bounds and where the end is an expression with side-effects. */ evaluate_bound (block, info->end, ar->end, desc, dim, false, - ar->as->type == AS_DEFERRED); + ar->as->type == AS_DEFERRED, save_value); /* Calculate the stride. */ @@ -4856,7 +4916,11 @@ gfc_conv_section_startstride (stmtblock_t * block, gfc_ss * ss, int dim) gfc_init_se (&se, NULL); gfc_conv_expr_type (&se, stride, gfc_array_index_type); gfc_add_block_to_block (block, &se.pre); - info->stride[dim] = gfc_evaluate_now (se.expr, block); + tree value = se.expr; + if (save_value) + info->stride[dim] = gfc_evaluate_now (value, block); + else + info->stride[dim] = value; } } @@ -5991,7 +6055,10 @@ gfc_set_delta (gfc_loopinfo *loop) gfc_array_index_type, info->start[dim], tmp); - info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre); + if (ss->is_alloc_lhs) + info->delta[dim] = tmp; + else + info->delta[dim] = gfc_evaluate_now (tmp, &outer_loop->pre); } } } @@ -6779,8 +6846,6 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, else gfc_add_expr_to_block (&se->pre, set_descriptor); - expr->symtree->n.sym->allocated_in_scope = 1; - return true; } @@ -8470,7 +8535,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr) gcc_assert (n == codim - 1); evaluate_bound (&loop.pre, info->start, ar->start, info->descriptor, n + ndim, true, - ar->as->type == AS_DEFERRED); + ar->as->type == AS_DEFERRED, true); loop.from[n + loop.dimen] = info->start[n + ndim]; } else @@ -11206,6 +11271,9 @@ gfc_is_reallocatable_lhs (gfc_expr *expr) gfc_ref * ref; gfc_symbol *sym; + if (!flag_realloc_lhs) + return false; + if (!expr->ref) return false; @@ -11330,6 +11398,51 @@ concat_str_length (gfc_expr* expr) } +static void +update_reallocated_descriptor (stmtblock_t *block, gfc_loopinfo *loop) +{ + for (gfc_ss *s = loop->ss; s != gfc_ss_terminator; s = s->loop_chain) + { + if (!s->is_alloc_lhs) + continue; + + gcc_assert (s->info->type == GFC_SS_SECTION); + gfc_array_info *info = &s->info->data.array; + tree desc = info->descriptor; + +#define UPDATE_VALUE(field, value) \ + do \ + { \ + if ((field) && VAR_P ((field))) \ + { \ + tree val = (value); \ + gfc_add_modify (block, (field), val); \ + } \ + else \ + (field) = gfc_evaluate_now ((field), block); \ + } \ + while (0) + + UPDATE_VALUE (info->offset, gfc_conv_descriptor_offset_get (desc)); + info->saved_offset = info->offset; + for (int i = 0; i < s->dimen; i++) + { + int dim = s->dim[i]; + tree tree_dim = gfc_rank_cst[dim]; + UPDATE_VALUE (info->start[dim], + gfc_conv_descriptor_lbound_get (desc, tree_dim)); + UPDATE_VALUE (info->end[dim], + gfc_conv_descriptor_ubound_get (desc, tree_dim)); + UPDATE_VALUE (info->stride[dim], + gfc_conv_descriptor_stride_get (desc, tree_dim)); + info->delta[dim] = gfc_evaluate_now (info->delta[dim], block); + } + +#undef UPDATE_VALUE + } +} + + /* Allocate the lhs of an assignment to an allocatable array, otherwise reallocate it. */ @@ -11341,8 +11454,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, stmtblock_t realloc_block; stmtblock_t alloc_block; stmtblock_t fblock; - stmtblock_t loop_pre_block; - gfc_ref *ref; gfc_ss *rss; gfc_ss *lss; gfc_array_info *linfo; @@ -11543,45 +11654,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, array1, build_int_cst (TREE_TYPE (array1), 0)); cond_null= gfc_evaluate_now (cond_null, &fblock); - /* If the data is null, set the descriptor bounds and offset. This suppresses - the maybe used uninitialized warning and forces the use of malloc because - the size is zero in all dimensions. Note that this block is only executed - if the lhs is unallocated and is only applied once in any namespace. - Component references are not subject to the warnings. */ - for (ref = expr1->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT) - break; - - if (!expr1->symtree->n.sym->allocated_in_scope && !ref) - { - gfc_start_block (&loop_pre_block); - for (n = 0; n < expr1->rank; n++) - { - gfc_conv_descriptor_lbound_set (&loop_pre_block, desc, - gfc_rank_cst[n], - gfc_index_one_node); - gfc_conv_descriptor_ubound_set (&loop_pre_block, desc, - gfc_rank_cst[n], - gfc_index_zero_node); - gfc_conv_descriptor_stride_set (&loop_pre_block, desc, - gfc_rank_cst[n], - gfc_index_zero_node); - } - - tmp = gfc_conv_descriptor_offset (desc); - gfc_add_modify (&loop_pre_block, tmp, gfc_index_zero_node); - - tmp = fold_build2_loc (input_location, EQ_EXPR, - logical_type_node, array1, - build_int_cst (TREE_TYPE (array1), 0)); - tmp = build3_v (COND_EXPR, tmp, - gfc_finish_block (&loop_pre_block), - build_empty_stmt (input_location)); - gfc_prepend_expr_to_block (&loop->pre, tmp); - - expr1->symtree->n.sym->allocated_in_scope = 1; - } - tmp = build3_v (COND_EXPR, cond_null, build1_v (GOTO_EXPR, jump_label1), build_empty_stmt (input_location)); @@ -11736,9 +11808,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, running offset. Use the saved_offset instead. */ tmp = gfc_conv_descriptor_offset (desc); gfc_add_modify (&fblock, tmp, offset); - if (linfo->saved_offset - && VAR_P (linfo->saved_offset)) - gfc_add_modify (&fblock, linfo->saved_offset, tmp); /* Now set the deltas for the lhs. */ for (n = 0; n < expr1->rank; n++) @@ -11748,8 +11817,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, tmp, loop->from[dim]); - if (linfo->delta[dim] && VAR_P (linfo->delta[dim])) - gfc_add_modify (&fblock, linfo->delta[dim], tmp); } /* Take into account _len of unlimited polymorphic entities, so that span @@ -11972,18 +12039,18 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, 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. */ - if (linfo->data && VAR_P (linfo->data)) - { - tmp = gfc_conv_descriptor_data_get (desc); - gfc_add_modify (&fblock, linfo->data, tmp); - } - /* Add the label for same shape lhs and rhs. */ tmp = build1_v (LABEL_EXPR, jump_label2); gfc_add_expr_to_block (&fblock, tmp); - return gfc_finish_block (&fblock); + tree realloc_code = gfc_finish_block (&fblock); + + stmtblock_t result_block; + gfc_init_block (&result_block); + gfc_add_expr_to_block (&result_block, realloc_code); + update_reallocated_descriptor (&result_block, loop); + + return gfc_finish_block (&result_block); } diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 3e0d763d2fb0..299acd3e3314 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -12875,11 +12875,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, if (gfc_is_reallocatable_lhs (expr1)) { lss->no_bounds_check = 1; - if (!(expr2->expr_type == EXPR_FUNCTION - && expr2->value.function.isym != NULL - && !(expr2->value.function.isym->elemental - || expr2->value.function.isym->conversion))) - lss->is_alloc_lhs = 1; + lss->is_alloc_lhs = 1; } else lss->no_bounds_check = expr1->no_bounds_check; @@ -12943,6 +12939,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp); } + tree reallocation = NULL_TREE; if (lss != gfc_ss_terminator) { /* The assignment needs scalarization. */ @@ -12961,8 +12958,12 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, /* Walk the rhs. */ rss = gfc_walk_expr (expr2); if (rss == gfc_ss_terminator) - /* The rhs is scalar. Add a ss for the expression. */ - rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2); + { + /* The rhs is scalar. Add a ss for the expression. */ + rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2); + lss->is_alloc_lhs = 0; + } + /* When doing a class assign, then the handle to the rhs needs to be a pointer to allow for polymorphism. */ if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2)) @@ -13011,6 +13012,14 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY; } + /* F2003: Allocate or reallocate lhs of allocatable array. */ + if (realloc_flag) + { + realloc_lhs_warning (expr1->ts.type, true, &expr1->where); + ompws_flags &= ~OMPWS_SCALARIZER_WS; + reallocation = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2); + } + /* Start the scalarized loop body. */ gfc_start_scalarized_body (&loop, &body); } @@ -13319,15 +13328,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, gfc_add_expr_to_block (&body, tmp); } - /* F2003: Allocate or reallocate lhs of allocatable array. */ - if (realloc_flag) - { - realloc_lhs_warning (expr1->ts.type, true, &expr1->where); - ompws_flags &= ~OMPWS_SCALARIZER_WS; - tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2); - if (tmp != NULL_TREE) - gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp); - } + if (reallocation != NULL_TREE) + gfc_add_expr_to_block (&loop.code[loop.dimen - 1], reallocation); if (maybe_workshare) ompws_flags &= ~OMPWS_SCALARIZER_BODY;