diff options
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/ChangeLog | 101 | ||||
| -rw-r--r-- | gcc/fortran/cpp.cc | 18 | ||||
| -rw-r--r-- | gcc/fortran/error.cc | 132 | ||||
| -rw-r--r-- | gcc/fortran/expr.cc | 5 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 4 | ||||
| -rw-r--r-- | gcc/fortran/options.cc | 3 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.cc | 162 | ||||
| -rw-r--r-- | gcc/fortran/trans-decl.cc | 16 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.cc | 64 |
9 files changed, 400 insertions, 105 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 33e12f1..52bd14c 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,104 @@ +2025-07-27 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/121185 + * trans-expr.cc (gfc_trans_assignment_1): Use the same condition + to set the is_alloc_lhs flag and to decide to generate + reallocation code. Add explicit call to gfc_fix_class_refs + before evaluating the condition. + +2025-07-27 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/121185 + * trans-array.cc (set_factored_descriptor_value): Also trigger + the saving of the previously selected reference on encountering + an INDIRECT_REF. Extract the saving code... + (save_ref): ... here as a new function. + +2025-07-27 Mikael Morin <mikael@gcc.gnu.org> + + PR fortran/121185 + * trans-expr.cc (gfc_get_class_from_expr): Give up class + container lookup on the second COMPONENT_REF after an array + descriptor. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * error.cc: Make diagnostics::context::m_source_printing private. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * cpp.cc: Update usage of "diagnostic_info" to explicitly refer to + "diagnostics::diagnostic_info". + * error.cc: Likewise. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * cpp.cc: Update for diagnostic_t becoming + enum class diagnostics::kind. + * error.cc: Likewise. + * options.cc: Likewise. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * cpp.cc: Update for renaming of + diagnostic_option_id to diagnostics::option_id. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * error.cc: Update for move of diagnostic-color.h to + diagnostics/color.h. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * error.cc: Update for diagnostic_context becoming + diagnostics::context. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * error.cc: Update to add "m_" prefix to fields of + diagnostic_info throughout. + +2025-07-25 David Malcolm <dmalcolm@redhat.com> + + * error.cc: Update for move of diagnostics output formats into + namespace "diagnostics" as "sinks". + * gfortran.h: Likewise. + +2025-07-23 Harald Anlauf <anlauf@gmx.de> + + PR fortran/121203 + * trans-expr.cc (gfc_conv_procedure_call): Obtain the character + length of an assumed character length procedure from the typespec + of the actual argument even if there is no explicit interface. + +2025-07-21 Mikael Morin <mikael@gcc.gnu.org> + + * trans-decl.cc (gfc_trans_deferred_vars): Fix indentation. + +2025-07-21 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/119106 + * expr.cc (simplify_constructor): Do not simplify constants. + (gfc_simplify_expr): Continue to simplify expression when an + iterator is present. + +2025-07-21 Mikael Morin <mikael@gcc.gnu.org> + + * trans-array.cc (gfc_conv_ss_descriptor): Move the descriptor + expression initialisation... + (set_factored_descriptor_value): ... to this new function. + Before initialisation, walk the reference expression passed as + argument and save some of its subexpressions to a variable. + (substitute_t): New struct. + (maybe_substitute_expr): New function. + (substitute_subexpr_in_expr): New function. + +2025-07-18 Harald Anlauf <anlauf@gmx.de> + + PR fortran/121145 + * trans-expr.cc (gfc_conv_procedure_call): Do not create pointer + check for proc-pointer actual passed to optional dummy. + 2025-07-16 Paul Thomas <pault@gcc.gnu.org> PR fortran/121060 diff --git a/gcc/fortran/cpp.cc b/gcc/fortran/cpp.cc index 1b70420..15ecc7d 100644 --- a/gcc/fortran/cpp.cc +++ b/gcc/fortran/cpp.cc @@ -1063,7 +1063,7 @@ cb_used_define (cpp_reader *pfile, location_t line ATTRIBUTE_UNUSED, /* Return the gcc option code associated with the reason for a cpp message, or 0 if none. */ -static diagnostic_option_id +static diagnostics::option_id cb_cpp_diagnostic_cpp_option (enum cpp_warning_reason reason) { const struct cpp_reason_option_codes_t *entry; @@ -1088,8 +1088,8 @@ cb_cpp_diagnostic (cpp_reader *pfile ATTRIBUTE_UNUSED, rich_location *richloc, const char *msg, va_list *ap) { - diagnostic_info diagnostic; - diagnostic_t dlevel; + diagnostics::diagnostic_info diagnostic; + enum diagnostics::kind dlevel; bool save_warn_system_headers = global_dc->m_warn_system_headers; bool ret; @@ -1099,22 +1099,22 @@ cb_cpp_diagnostic (cpp_reader *pfile ATTRIBUTE_UNUSED, global_dc->m_warn_system_headers = 1; /* Fall through. */ case CPP_DL_WARNING: - dlevel = DK_WARNING; + dlevel = diagnostics::kind::warning; break; case CPP_DL_PEDWARN: - dlevel = DK_PEDWARN; + dlevel = diagnostics::kind::pedwarn; break; case CPP_DL_ERROR: - dlevel = DK_ERROR; + dlevel = diagnostics::kind::error; break; case CPP_DL_ICE: - dlevel = DK_ICE; + dlevel = diagnostics::kind::ice; break; case CPP_DL_NOTE: - dlevel = DK_NOTE; + dlevel = diagnostics::kind::note; break; case CPP_DL_FATAL: - dlevel = DK_FATAL; + dlevel = diagnostics::kind::fatal; break; default: gcc_unreachable (); diff --git a/gcc/fortran/error.cc b/gcc/fortran/error.cc index 004a4b2..ebf9e61 100644 --- a/gcc/fortran/error.cc +++ b/gcc/fortran/error.cc @@ -31,9 +31,9 @@ along with GCC; see the file COPYING3. If not see #include "gfortran.h" #include "diagnostic.h" -#include "diagnostic-color.h" +#include "diagnostics/color.h" #include "tree-diagnostic.h" /* tree_diagnostics_defaults */ -#include "diagnostic-format-text.h" +#include "diagnostics/text-sink.h" static int suppress_errors = 0; @@ -43,7 +43,7 @@ static bool warnings_not_errors = false; static bool buffered_p; static gfc_error_buffer *error_buffer; -static diagnostic_buffer *pp_error_buffer, *pp_warning_buffer; +static diagnostics::buffer *pp_error_buffer, *pp_warning_buffer; gfc_error_buffer::gfc_error_buffer () : flag (false), buffer (*global_dc) @@ -228,7 +228,7 @@ gfc_print_wide_char (gfc_char_t c) it to global_dc. */ static void -gfc_clear_diagnostic_buffer (diagnostic_buffer *this_buffer) +gfc_clear_diagnostic_buffer (diagnostics::buffer *this_buffer) { gcc_assert (this_buffer); global_dc->clear_diagnostic_buffer (*this_buffer); @@ -237,13 +237,13 @@ gfc_clear_diagnostic_buffer (diagnostic_buffer *this_buffer) /* The currently-printing diagnostic, for use by gfc_format_decoder, for colorizing %C and %L. */ -static diagnostic_info *curr_diagnostic; +static diagnostics::diagnostic_info *curr_diagnostic; /* A helper function to call diagnostic_report_diagnostic, while setting curr_diagnostic for the duration of the call. */ static bool -gfc_report_diagnostic (diagnostic_info *diagnostic) +gfc_report_diagnostic (diagnostics::diagnostic_info *diagnostic) { gcc_assert (diagnostic != NULL); curr_diagnostic = diagnostic; @@ -261,9 +261,9 @@ gfc_warning (int opt, const char *gmsgid, va_list ap) va_list argp; va_copy (argp, ap); - diagnostic_info diagnostic; + diagnostics::diagnostic_info diagnostic; rich_location rich_loc (line_table, UNKNOWN_LOCATION); - diagnostic_buffer *old_buffer = global_dc->get_diagnostic_buffer (); + diagnostics::buffer *old_buffer = global_dc->get_diagnostic_buffer (); gcc_assert (!old_buffer); gfc_clear_diagnostic_buffer (pp_warning_buffer); @@ -272,8 +272,8 @@ gfc_warning (int opt, const char *gmsgid, va_list ap) global_dc->set_diagnostic_buffer (pp_warning_buffer); diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, - DK_WARNING); - diagnostic.option_id = opt; + diagnostics::kind::warning); + diagnostic.m_option_id = opt; bool ret = gfc_report_diagnostic (&diagnostic); if (buffered_p) @@ -441,7 +441,7 @@ gfc_format_decoder (pretty_printer *pp, text_info *text, const char *spec, const char *color = (loc_num ? "range1" - : diagnostic_get_color_for_kind (curr_diagnostic->kind)); + : diagnostics::get_color_for_kind (curr_diagnostic->m_kind)); pp_string (pp, colorize_start (pp_show_color (pp), color)); pp_string (pp, result[loc_num]); pp_string (pp, colorize_stop (pp_show_color (pp))); @@ -460,8 +460,8 @@ gfc_format_decoder (pretty_printer *pp, text_info *text, const char *spec, /* Return a malloc'd string describing the kind of diagnostic. The caller is responsible for freeing the memory. */ static char * -gfc_diagnostic_build_kind_prefix (diagnostic_context *context, - const diagnostic_info *diagnostic) +gfc_diagnostic_build_kind_prefix (diagnostics::context *context, + const diagnostics::diagnostic_info *diagnostic) { static const char *const diagnostic_kind_text[] = { #define DEFINE_DIAGNOSTIC_KIND(K, T, C) (T), @@ -475,15 +475,16 @@ gfc_diagnostic_build_kind_prefix (diagnostic_context *context, #undef DEFINE_DIAGNOSTIC_KIND NULL }; - gcc_assert (diagnostic->kind < DK_LAST_DIAGNOSTIC_KIND); - const char *text = _(diagnostic_kind_text[diagnostic->kind]); + const int diag_kind_idx = static_cast<int> (diagnostic->m_kind); + gcc_assert (diagnostic->m_kind < diagnostics::kind::last_diagnostic_kind); + const char *text = _(diagnostic_kind_text[diag_kind_idx]); const char *text_cs = "", *text_ce = ""; pretty_printer *const pp = context->get_reference_printer (); - if (diagnostic_kind_color[diagnostic->kind]) +if (diagnostic_kind_color[diag_kind_idx]) { text_cs = colorize_start (pp_show_color (pp), - diagnostic_kind_color[diagnostic->kind]); + diagnostic_kind_color[diag_kind_idx]); text_ce = colorize_stop (pp_show_color (pp)); } return build_message_string ("%s%s:%s ", text_cs, text, text_ce); @@ -492,7 +493,7 @@ gfc_diagnostic_build_kind_prefix (diagnostic_context *context, /* Return a malloc'd string describing a location. The caller is responsible for freeing the memory. */ static char * -gfc_diagnostic_build_locus_prefix (const diagnostic_location_print_policy &loc_policy, +gfc_diagnostic_build_locus_prefix (const diagnostics::location_print_policy &loc_policy, expanded_location s, bool colorize) { @@ -511,7 +512,7 @@ gfc_diagnostic_build_locus_prefix (const diagnostic_location_print_policy &loc_p /* Return a malloc'd string describing two locations. The caller is responsible for freeing the memory. */ static char * -gfc_diagnostic_build_locus_prefix (const diagnostic_location_print_policy &loc_policy, +gfc_diagnostic_build_locus_prefix (const diagnostics::location_print_policy &loc_policy, expanded_location s, expanded_location s2, bool colorize) { @@ -548,16 +549,16 @@ gfc_diagnostic_build_locus_prefix (const diagnostic_location_print_policy &loc_p [locus of primary range]: Error: Some error at (1) and (2) */ static void -gfc_diagnostic_text_starter (diagnostic_text_output_format &text_output, - const diagnostic_info *diagnostic) +gfc_diagnostic_text_starter (diagnostics::text_sink &text_output, + const diagnostics::diagnostic_info *diagnostic) { - diagnostic_context *const context = &text_output.get_context (); + diagnostics::context *const context = &text_output.get_context (); pretty_printer *const pp = text_output.get_printer (); char * kind_prefix = gfc_diagnostic_build_kind_prefix (context, diagnostic); expanded_location s1 = diagnostic_expand_location (diagnostic); expanded_location s2; - bool one_locus = diagnostic->richloc->get_num_locations () < 2; + bool one_locus = diagnostic->m_richloc->get_num_locations () < 2; bool same_locus = false; if (!one_locus) @@ -566,13 +567,13 @@ gfc_diagnostic_text_starter (diagnostic_text_output_format &text_output, same_locus = diagnostic_same_line (context, s1, s2); } - diagnostic_location_print_policy loc_policy (text_output); + diagnostics::location_print_policy loc_policy (text_output); const bool colorize = pp_show_color (pp); char * locus_prefix = (one_locus || !same_locus) ? gfc_diagnostic_build_locus_prefix (loc_policy, s1, colorize) : gfc_diagnostic_build_locus_prefix (loc_policy, s1, s2, colorize); - if (!context->m_source_printing.enabled + if (!context->get_source_printing_options ().enabled || diagnostic_location (diagnostic, 0) <= BUILTINS_LOCATION || diagnostic_location (diagnostic, 0) == context->m_last_location) { @@ -608,7 +609,7 @@ gfc_diagnostic_text_starter (diagnostic_text_output_format &text_output, pp_newline (pp); diagnostic_show_locus (context, text_output.get_source_printing_options (), - diagnostic->richloc, diagnostic->kind, + diagnostic->m_richloc, diagnostic->m_kind, pp); /* If the caret line was shown, the prefix does not contain the locus. */ @@ -617,11 +618,11 @@ gfc_diagnostic_text_starter (diagnostic_text_output_format &text_output, } static void -gfc_diagnostic_start_span (const diagnostic_location_print_policy &loc_policy, - to_text &sink, +gfc_diagnostic_start_span (const diagnostics::location_print_policy &loc_policy, + diagnostics::to_text &sink, expanded_location exploc) { - pretty_printer *pp = get_printer (sink); + pretty_printer *pp = diagnostics::get_printer (sink); const bool colorize = pp_show_color (pp); char *locus_prefix = gfc_diagnostic_build_locus_prefix (loc_policy, exploc, colorize); @@ -634,9 +635,9 @@ gfc_diagnostic_start_span (const diagnostic_location_print_policy &loc_policy, static void -gfc_diagnostic_text_finalizer (diagnostic_text_output_format &text_output, - const diagnostic_info *diagnostic ATTRIBUTE_UNUSED, - diagnostic_t orig_diag_kind ATTRIBUTE_UNUSED) +gfc_diagnostic_text_finalizer (diagnostics::text_sink &text_output, + const diagnostics::diagnostic_info *, + enum diagnostics::kind orig_diag_kind ATTRIBUTE_UNUSED) { pretty_printer *const pp = text_output.get_printer (); pp_destroy_prefix (pp); @@ -650,13 +651,14 @@ bool gfc_warning_now_at (location_t loc, int opt, const char *gmsgid, ...) { va_list argp; - diagnostic_info diagnostic; + diagnostics::diagnostic_info diagnostic; rich_location rich_loc (line_table, loc); bool ret; va_start (argp, gmsgid); - diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_WARNING); - diagnostic.option_id = opt; + diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, + diagnostics::kind::warning); + diagnostic.m_option_id = opt; ret = gfc_report_diagnostic (&diagnostic); va_end (argp); return ret; @@ -668,14 +670,14 @@ bool gfc_warning_now (int opt, const char *gmsgid, ...) { va_list argp; - diagnostic_info diagnostic; + diagnostics::diagnostic_info diagnostic; rich_location rich_loc (line_table, UNKNOWN_LOCATION); bool ret; va_start (argp, gmsgid); diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, - DK_WARNING); - diagnostic.option_id = opt; + diagnostics::kind::warning); + diagnostic.m_option_id = opt; ret = gfc_report_diagnostic (&diagnostic); va_end (argp); return ret; @@ -687,14 +689,14 @@ bool gfc_warning_internal (int opt, const char *gmsgid, ...) { va_list argp; - diagnostic_info diagnostic; + diagnostics::diagnostic_info diagnostic; rich_location rich_loc (line_table, UNKNOWN_LOCATION); bool ret; va_start (argp, gmsgid); diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, - DK_WARNING); - diagnostic.option_id = opt; + diagnostics::kind::warning); + diagnostic.m_option_id = opt; ret = gfc_report_diagnostic (&diagnostic); va_end (argp); return ret; @@ -706,13 +708,14 @@ void gfc_error_now (const char *gmsgid, ...) { va_list argp; - diagnostic_info diagnostic; + diagnostics::diagnostic_info diagnostic; rich_location rich_loc (line_table, UNKNOWN_LOCATION); error_buffer->flag = true; va_start (argp, gmsgid); - diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_ERROR); + diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, + diagnostics::kind::error); gfc_report_diagnostic (&diagnostic); va_end (argp); } @@ -724,11 +727,12 @@ void gfc_fatal_error (const char *gmsgid, ...) { va_list argp; - diagnostic_info diagnostic; + diagnostics::diagnostic_info diagnostic; rich_location rich_loc (line_table, UNKNOWN_LOCATION); va_start (argp, gmsgid); - diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_FATAL); + diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, + diagnostics::kind::fatal); gfc_report_diagnostic (&diagnostic); va_end (argp); @@ -776,9 +780,9 @@ gfc_error_opt (int opt, const char *gmsgid, va_list ap) return; } - diagnostic_info diagnostic; + diagnostics::diagnostic_info diagnostic; rich_location richloc (line_table, UNKNOWN_LOCATION); - diagnostic_buffer *old_buffer = global_dc->get_diagnostic_buffer (); + diagnostics::buffer *old_buffer = global_dc->get_diagnostic_buffer (); gcc_assert (!old_buffer); gfc_clear_diagnostic_buffer (pp_error_buffer); @@ -786,7 +790,8 @@ gfc_error_opt (int opt, const char *gmsgid, va_list ap) if (buffered_p) global_dc->set_diagnostic_buffer (pp_error_buffer); - diagnostic_set_info (&diagnostic, gmsgid, &argp, &richloc, DK_ERROR); + diagnostic_set_info (&diagnostic, gmsgid, &argp, &richloc, + diagnostics::kind::error); gfc_report_diagnostic (&diagnostic); if (buffered_p) @@ -823,7 +828,7 @@ gfc_internal_error (const char *gmsgid, ...) { int e, w; va_list argp; - diagnostic_info diagnostic; + diagnostics::diagnostic_info diagnostic; rich_location rich_loc (line_table, UNKNOWN_LOCATION); gfc_get_errors (&w, &e); @@ -831,7 +836,8 @@ gfc_internal_error (const char *gmsgid, ...) exit(EXIT_FAILURE); va_start (argp, gmsgid); - diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, DK_ICE); + diagnostic_set_info (&diagnostic, gmsgid, &argp, &rich_loc, + diagnostics::kind::ice); gfc_report_diagnostic (&diagnostic); va_end (argp); @@ -885,8 +891,8 @@ static void gfc_move_error_buffer_from_to (gfc_error_buffer * buffer_from, gfc_error_buffer * buffer_to) { - diagnostic_buffer * from = &(buffer_from->buffer); - diagnostic_buffer * to = &(buffer_to->buffer); + diagnostics::buffer * from = &(buffer_from->buffer); + diagnostics::buffer * to = &(buffer_to->buffer); buffer_to->flag = buffer_from->flag; buffer_from->flag = false; @@ -950,13 +956,14 @@ gfc_errors_to_warnings (bool f) void gfc_diagnostics_init (void) { - diagnostic_text_starter (global_dc) = gfc_diagnostic_text_starter; - diagnostic_start_span (global_dc) = gfc_diagnostic_start_span; - diagnostic_text_finalizer (global_dc) = gfc_diagnostic_text_finalizer; + diagnostics::text_starter (global_dc) = gfc_diagnostic_text_starter; + diagnostics::start_span (global_dc) = gfc_diagnostic_start_span; + diagnostics::text_finalizer (global_dc) = gfc_diagnostic_text_finalizer; global_dc->set_format_decoder (gfc_format_decoder); - global_dc->m_source_printing.caret_chars[0] = '1'; - global_dc->m_source_printing.caret_chars[1] = '2'; - pp_warning_buffer = new diagnostic_buffer (*global_dc); + auto &source_printing_opts = global_dc->get_source_printing_options (); + source_printing_opts.caret_chars[0] = '1'; + source_printing_opts.caret_chars[1] = '2'; + pp_warning_buffer = new diagnostics::buffer (*global_dc); error_buffer = new gfc_error_buffer (); pp_error_buffer = &(error_buffer->buffer); } @@ -967,10 +974,11 @@ gfc_diagnostics_finish (void) tree_diagnostics_defaults (global_dc); /* We still want to use the gfc starter and finalizer, not the tree defaults. */ - diagnostic_text_starter (global_dc) = gfc_diagnostic_text_starter; - diagnostic_text_finalizer (global_dc) = gfc_diagnostic_text_finalizer; - global_dc->m_source_printing.caret_chars[0] = '^'; - global_dc->m_source_printing.caret_chars[1] = '^'; + diagnostics::text_starter (global_dc) = gfc_diagnostic_text_starter; + diagnostics::text_finalizer (global_dc) = gfc_diagnostic_text_finalizer; + auto &source_printing_opts = global_dc->get_source_printing_options (); + source_printing_opts.caret_chars[0] = '^'; + source_printing_opts.caret_chars[1] = '^'; delete error_buffer; error_buffer = nullptr; pp_error_buffer = nullptr; diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index b0495b7..b8d04ff 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -1372,7 +1372,7 @@ simplify_constructor (gfc_constructor_base base, int type) || !gfc_simplify_expr (c->iterator->step, type))) return false; - if (c->expr) + if (c->expr && c->expr->expr_type != EXPR_CONSTANT) { /* Try and simplify a copy. Replace the original if successful but keep going through the constructor at all costs. Not @@ -2469,7 +2469,8 @@ gfc_simplify_expr (gfc_expr *p, int type) { if (!simplify_parameter_variable (p, type)) return false; - break; + if (!iter_stack) + break; } if (type == 1) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index d85095c..85feb18 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3594,11 +3594,11 @@ bool gfc_notify_std (int, const char *, ...) ATTRIBUTE_GCC_GFC(2,3); #define gfc_syntax_error(ST) \ gfc_error ("Syntax error in %s statement at %C", gfc_ascii_statement (ST)); -#include "diagnostic-buffer.h" /* For diagnostic_buffer. */ +#include "diagnostics/buffering.h" /* For diagnostics::buffer. */ struct gfc_error_buffer { bool flag; - diagnostic_buffer buffer; + diagnostics::buffer buffer; gfc_error_buffer(); }; diff --git a/gcc/fortran/options.cc b/gcc/fortran/options.cc index d3c9066..821a8c8 100644 --- a/gcc/fortran/options.cc +++ b/gcc/fortran/options.cc @@ -406,7 +406,8 @@ gfc_post_options (const char **pfilename) if (warn_line_truncation && !OPTION_SET_P (warnings_are_errors) && option_unspecified_p (OPT_Wline_truncation)) diagnostic_classify_diagnostic (global_dc, OPT_Wline_truncation, - DK_ERROR, UNKNOWN_LOCATION); + diagnostics::kind::error, + UNKNOWN_LOCATION); } else { diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 1561936..6b759d1 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -3437,6 +3437,166 @@ save_descriptor_data (tree descr, tree data) } +/* Type of the DATA argument passed to walk_tree by substitute_subexpr_in_expr + and used by maybe_substitute_expr. */ + +typedef struct +{ + tree target, repl; +} +substitute_t; + + +/* Check if the expression in *TP is equal to the substitution target provided + in DATA->TARGET and replace it with DATA->REPL in that case. This is a + callback function for use with walk_tree. */ + +static tree +maybe_substitute_expr (tree *tp, int *walk_subtree, void *data) +{ + substitute_t *subst = (substitute_t *) data; + if (*tp == subst->target) + { + *tp = subst->repl; + *walk_subtree = 0; + } + + return NULL_TREE; +} + + +/* Substitute in EXPR any occurence of TARGET with REPLACEMENT. */ + +static void +substitute_subexpr_in_expr (tree target, tree replacement, tree expr) +{ + substitute_t subst; + subst.target = target; + subst.repl = replacement; + + walk_tree (&expr, maybe_substitute_expr, &subst, nullptr); +} + + +/* Save REF to a fresh variable in all of REPLACEMENT_ROOTS, appending extra + code to CODE. Before returning, add REF to REPLACEMENT_ROOTS and clear + REF. */ + +static void +save_ref (tree &code, tree &ref, vec<tree> &replacement_roots) +{ + stmtblock_t tmp_block; + gfc_init_block (&tmp_block); + tree var = gfc_evaluate_now (ref, &tmp_block); + gfc_add_expr_to_block (&tmp_block, code); + code = gfc_finish_block (&tmp_block); + + unsigned i; + tree repl_root; + FOR_EACH_VEC_ELT (replacement_roots, i, repl_root) + substitute_subexpr_in_expr (ref, var, repl_root); + + replacement_roots.safe_push (ref); + ref = NULL_TREE; +} + + +/* Save the descriptor reference VALUE to storage pointed by DESC_PTR. Before + that, try to factor subexpressions of VALUE to variables, adding extra code + to BLOCK. + + The candidate references to factoring are dereferenced pointers because they + are cheap to copy and array descriptors because they are often the base of + multiple subreferences. */ + +static void +set_factored_descriptor_value (tree *desc_ptr, tree value, stmtblock_t *block) +{ + /* As the reference is processed from outer to inner, variable definitions + will be generated in reversed order, so can't be put directly in BLOCK. + We use TMP_BLOCK instead. */ + tree accumulated_code = NULL_TREE; + + /* The current candidate to factoring. */ + tree saveable_ref = NULL_TREE; + + /* The root expressions in which we look for subexpressions to replace with + variables. */ + auto_vec<tree> replacement_roots; + replacement_roots.safe_push (value); + + tree data_ref = value; + tree next_ref = NULL_TREE; + + /* If the candidate reference is not followed by a subreference, it can't be + saved to a variable as it may be reallocatable, and we have to keep the + parent reference to be able to store the new pointer value in case of + reallocation. */ + bool maybe_reallocatable = true; + + while (true) + { + if (!maybe_reallocatable + && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (data_ref))) + saveable_ref = data_ref; + + if (TREE_CODE (data_ref) == INDIRECT_REF) + { + next_ref = TREE_OPERAND (data_ref, 0); + + if (!maybe_reallocatable) + { + if (saveable_ref != NULL_TREE && saveable_ref != data_ref) + { + /* A reference worth saving has been seen, and now the pointer + to the current reference is also worth saving. If the + previous reference to save wasn't the current one, do save + it now. Otherwise drop it as we prefer saving the + pointer. */ + save_ref (accumulated_code, saveable_ref, replacement_roots); + } + + /* Don't evaluate the pointer to a variable yet; do it only if the + variable would be significantly more simple than the reference + it replaces. That is if the reference contains anything + different from NOPs, COMPONENTs and DECLs. */ + saveable_ref = next_ref; + } + } + else if (TREE_CODE (data_ref) == COMPONENT_REF) + { + maybe_reallocatable = false; + next_ref = TREE_OPERAND (data_ref, 0); + } + else if (TREE_CODE (data_ref) == NOP_EXPR) + next_ref = TREE_OPERAND (data_ref, 0); + else + { + if (DECL_P (data_ref)) + break; + + if (TREE_CODE (data_ref) == ARRAY_REF) + { + maybe_reallocatable = false; + next_ref = TREE_OPERAND (data_ref, 0); + } + + if (saveable_ref != NULL_TREE) + /* We have seen a reference worth saving. Do it now. */ + save_ref (accumulated_code, saveable_ref, replacement_roots); + + if (TREE_CODE (data_ref) != ARRAY_REF) + break; + } + + data_ref = next_ref; + } + + *desc_ptr = value; + gfc_add_expr_to_block (block, accumulated_code); +} + + /* Translate expressions for the descriptor and data pointer of a SS. */ /*GCC ARRAYS*/ @@ -3457,7 +3617,7 @@ 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; + set_factored_descriptor_value (&info->descriptor, se.expr, block); ss_info->string_length = se.string_length; ss_info->class_container = se.class_container; diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index 43bd7be..d5acdca 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -4773,14 +4773,14 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) /* Nullify explicit return class arrays on entry. */ tree type; tmp = get_proc_result (proc_sym); - if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp))) - { - gfc_start_block (&init); - tmp = gfc_class_data_get (tmp); - type = TREE_TYPE (gfc_conv_descriptor_data_get (tmp)); - gfc_conv_descriptor_data_set (&init, tmp, build_int_cst (type, 0)); - gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); - } + if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp))) + { + gfc_start_block (&init); + tmp = gfc_class_data_get (tmp); + type = TREE_TYPE (gfc_conv_descriptor_data_get (tmp)); + gfc_conv_descriptor_data_set (&init, tmp, build_int_cst (type, 0)); + gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); + } } diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 082987f..0db7ba3 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -714,6 +714,8 @@ gfc_get_class_from_expr (tree expr) { tree tmp; tree type; + bool array_descr_found = false; + bool comp_after_descr_found = false; for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0)) { @@ -725,6 +727,8 @@ gfc_get_class_from_expr (tree expr) { if (GFC_CLASS_TYPE_P (type)) return tmp; + if (GFC_DESCRIPTOR_TYPE_P (type)) + array_descr_found = true; if (type != TYPE_CANONICAL (type)) type = TYPE_CANONICAL (type); else @@ -732,6 +736,23 @@ gfc_get_class_from_expr (tree expr) } if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL) break; + + /* Avoid walking up the reference chain too far. For class arrays, the + array descriptor is a direct component (through a pointer) of the class + container. So there is exactly one COMPONENT_REF between a class + container and its child array descriptor. After seeing an array + descriptor, we can give up on the second COMPONENT_REF we see, if no + class container was found until that point. */ + if (array_descr_found) + { + if (comp_after_descr_found) + { + if (TREE_CODE (tmp) == COMPONENT_REF) + return NULL_TREE; + } + else if (TREE_CODE (tmp) == COMPONENT_REF) + comp_after_descr_found = true; + } } if (POINTER_TYPE_P (TREE_TYPE (tmp))) @@ -7909,21 +7930,21 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, se->ss->info->class_container = arg1_cntnr; } - if (fsym && e) + /* Obtain the character length of an assumed character length procedure + from the typespec of the actual argument. */ + if (e + && parmse.string_length == NULL_TREE + && e->ts.type == BT_PROCEDURE + && e->symtree->n.sym->ts.type == BT_CHARACTER + && e->symtree->n.sym->ts.u.cl->length != NULL + && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT) { - /* Obtain the character length of an assumed character length - length procedure from the typespec. */ - if (fsym->ts.type == BT_CHARACTER - && parmse.string_length == NULL_TREE - && e->ts.type == BT_PROCEDURE - && e->symtree->n.sym->ts.type == BT_CHARACTER - && e->symtree->n.sym->ts.u.cl->length != NULL - && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT) - { - gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl); - parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl; - } + gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl); + parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl; + } + if (fsym && e) + { /* Obtain the character length for a NULL() actual with a character MOLD argument. Otherwise substitute a suitable dummy length. Here we handle non-optional dummies of non-bind(c) procedures. */ @@ -8159,7 +8180,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, msg = xasprintf ("Pointer actual argument '%s' is not " "associated", e->symtree->n.sym->name); else if (attr.proc_pointer && !e->value.function.actual - && (fsym == NULL || !fsym_attr.proc_pointer)) + && (fsym == NULL + || (!fsym_attr.proc_pointer && !fsym_attr.optional))) msg = xasprintf ("Proc-pointer actual argument '%s' is not " "associated", e->symtree->n.sym->name); else @@ -12870,9 +12892,16 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, gfc_init_se (&lse, NULL); gfc_init_se (&rse, NULL); + gfc_fix_class_refs (expr1); + + realloc_flag = flag_realloc_lhs + && gfc_is_reallocatable_lhs (expr1) + && expr2->rank + && !is_runtime_conformable (expr1, expr2); + /* Walk the lhs. */ lss = gfc_walk_expr (expr1); - if (gfc_is_reallocatable_lhs (expr1)) + if (realloc_flag) { lss->no_bounds_check = 1; lss->is_alloc_lhs = 1; @@ -12923,11 +12952,6 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, assoc_assign = is_assoc_assign (expr1, expr2); - realloc_flag = flag_realloc_lhs - && gfc_is_reallocatable_lhs (expr1) - && expr2->rank - && !is_runtime_conformable (expr1, expr2); - /* Only analyze the expressions for coarray properties, when in coarray-lib mode. Avoid false-positive uninitialized diagnostics with initializing the codimension flag unconditionally. */ |