diff options
Diffstat (limited to 'gcc/fortran')
| -rw-r--r-- | gcc/fortran/ChangeLog | 253 | ||||
| -rw-r--r-- | gcc/fortran/check.cc | 21 | ||||
| -rw-r--r-- | gcc/fortran/class.cc | 24 | ||||
| -rw-r--r-- | gcc/fortran/cpp.cc | 18 | ||||
| -rw-r--r-- | gcc/fortran/decl.cc | 206 | ||||
| -rw-r--r-- | gcc/fortran/error.cc | 132 | ||||
| -rw-r--r-- | gcc/fortran/expr.cc | 5 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 26 | ||||
| -rw-r--r-- | gcc/fortran/interface.cc | 7 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.cc | 8 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.h | 2 | ||||
| -rw-r--r-- | gcc/fortran/intrinsic.texi | 64 | ||||
| -rw-r--r-- | gcc/fortran/invoke.texi | 4 | ||||
| -rw-r--r-- | gcc/fortran/iresolve.cc | 13 | ||||
| -rw-r--r-- | gcc/fortran/openmp.cc | 30 | ||||
| -rw-r--r-- | gcc/fortran/options.cc | 3 | ||||
| -rw-r--r-- | gcc/fortran/parse.cc | 5 | ||||
| -rw-r--r-- | gcc/fortran/resolve.cc | 165 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.cc | 519 | ||||
| -rw-r--r-- | gcc/fortran/trans-array.h | 5 | ||||
| -rw-r--r-- | gcc/fortran/trans-decl.cc | 32 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.cc | 134 | ||||
| -rw-r--r-- | gcc/fortran/trans-intrinsic.cc | 72 | ||||
| -rw-r--r-- | gcc/fortran/trans-openmp.cc | 18 | ||||
| -rw-r--r-- | gcc/fortran/trans-stmt.cc | 7 | ||||
| -rw-r--r-- | gcc/fortran/trans.h | 2 |
26 files changed, 1458 insertions, 317 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 49eef94..d75d64f 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,256 @@ +2025-08-01 Mikael Morin <mikael@gcc.gnu.org> + + * trans-decl.cc (gfc_trans_deferred_vars): Fix closing brace in + a comment. + +2025-07-31 Mikael Morin <morin-mikael@orange.fr> + + PR fortran/121342 + * trans-expr.cc (gfc_conv_subref_array_arg): Remove offset + update. + (gfc_conv_procedure_call): For polymorphic functions, move the + scalarizer descriptor information... + * trans-array.cc (gfc_add_loop_ss_code): ... here, and evaluate + the bounds to fresh variables. + (get_class_info_from_ss): Remove offset update. + (gfc_conv_ss_startstride): Don't set a zero value for function + result upper bounds. + (late_set_loop_bounds): New. + (gfc_conv_loop_setup): If the bounds of a function result have + been set, and no other array provided loop bounds for a + dimension, use the function result bounds as loop bounds for + that dimension. + (gfc_set_delta): Don't skip delta setting for polymorphic + function results. + +2025-07-30 Mikael Morin <morin-mikael@orange.fr> + + * trans-array.cc (gfc_array_init_size): Remove the nelems + argument. + (gfc_array_allocate): Update caller. Remove the nelems + argument. + * trans-stmt.cc (gfc_trans_allocate): Update caller. Remove the + nelems variable. + * trans-array.h (gfc_array_allocate): Update prototype. + +2025-07-30 Yuao Ma <c8ef@outlook.com> + + * check.cc (gfc_check_split): Argument check for SPLIT. + * gfortran.h (enum gfc_isym_id): Define GFC_ISYM_SPLIT. + * intrinsic.cc (add_subroutines): Register SPLIT intrinsic. + * intrinsic.h (gfc_check_split): New decl. + (gfc_resolve_split): Ditto. + * intrinsic.texi: SPLIT documentation. + * iresolve.cc (gfc_resolve_split): Add resolved_sym for SPLIT. + * trans-decl.cc (gfc_build_intrinsic_function_decls): Add decl for + SPLIT in libgfortran. + * trans-intrinsic.cc (conv_intrinsic_split): SPLIT codegen. + (gfc_conv_intrinsic_subroutine): Handle SPLIT case. + * trans.h (GTY): Declare gfor_fndecl_string_split{, _char4}. + +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 + * interface.cc (matching_typebound_op): Defer determination of + specific procedure until resolution by returning NULL. + +2025-07-16 Steve Kargl <sgk@troutmask.apl.washington.edu> + + * decl.cc (gfc_match_import): Correct minor whitespace snafu + and fix NULL pointer dereferences in two places. + +2025-07-15 Kwok Cheung Yeung <kcyeung@baylibre.com> + + PR fortran/104428 + * trans-openmp.cc (gfc_trans_omp_declare_variant): Check that proc_st + is non-NULL before dereferencing. Add line number to error message. + +2025-07-15 Mikael Morin <mikael@gcc.gnu.org> + + * gfortran.h (gfc_symbol): Remove field allocated_in_scope. + * trans-array.cc (gfc_array_allocate): Don't set it. + (gfc_alloc_allocatable_for_assignment): Likewise. + Generate the unallocated descriptor bounds initialisation + before the opening of the reallocation code block. Create a + variable and use it as additional condition to the unallocated + descriptor bounds initialisation. + +2025-07-15 Mikael Morin <mikael@gcc.gnu.org> + + * trans-array.cc (gfc_conv_ss_descriptor): Don't evaluate + offset and data to a variable if is_alloc_lhs is set. Move the + existing evaluation decision condition for data... + (save_descriptor_data): ... here as a new predicate. + (evaluate_bound): Add argument save_value. Omit the evaluation + of the value to a variable if that argument isn't set. + (gfc_conv_expr_descriptor): Update caller. + (gfc_conv_section_startstride): Update caller. Set save_value + if is_alloc_lhs is not set. Omit the evaluation of stride to a + variable if save_value isn't set. + (gfc_set_delta): Omit the evaluation of delta to a variable + if is_alloc_lhs is set. + (gfc_is_reallocatable_lhs): Return false if flag_realloc_lhs + isn't set. + (gfc_alloc_allocatable_for_assignment): Don't update + the variables that may be stored in saved_offset, delta, and + data. Call instead... + (update_reallocated_descriptor): ... this new procedure. + * trans-expr.cc (gfc_trans_assignment_1): Don't omit setting the + is_alloc_lhs flag if the right hand side is an intrinsic + function. Clear the flag if the right hand side is scalar. + +2025-07-15 Mikael Morin <mikael@gcc.gnu.org> + + * trans-expr.cc (gfc_trans_assignment_1): Generate array + reallocation code before entering the scalarisation loops. + +2025-07-15 Filip Kastl <fkastl@suse.cz> + + * resolve.cc (resolve_select_type): Fix indentation. + +2025-07-12 Tobias Burnus <tburnus@baylibre.com> + + * invoke.texi (-Wsurprising): Note about OpenACC warning + related to PARAMATER. + * openmp.cc (resolve_omp_clauses, gfc_resolve_oacc_declare): + Accept PARAMETER for OpenACC but add surprising warning. + * trans-openmp.cc (gfc_trans_omp_variable_list, + gfc_trans_omp_clauses): Ignore PARAMETER inside clauses. + +2025-07-11 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/106135 + * decl.cc (build_sym): Emit an error if a symbol associated by + an IMPORT, ONLY or IMPORT, all statement is being redeclared. + (gfc_match_import): Parse and check the F2018 versions of the + IMPORT statement. For scopes other than and interface body, if + the symbol cannot be found in the host scope, generate it and + set it up such that gfc_fixup_sibling_symbols can transfer its + 'imported attribute' if it turnes out to be a not yet parsed + procedure. Test for violations of C897-8100. + * gfortran.h : Add 'import_only' to the gfc_symtree structure. + Add the enum, 'importstate', which is used for values the new + field 'import_state' in gfc_namespace. + * parse.cc (gfc_fixup_sibling_symbols): Transfer the attribute + 'imported' to the new symbol. + * resolve.cc (check_sym_import_status, check_import_status): + New functions to test symbols and expressions for violations of + F2018:C8102. + (resolve_call): Test the 'resolved_sym' against C8102 by a call + to 'check_sym_import_status'. + (gfc_resolve_expr): If the expression is OK and an IMPORT + statement has been registered in the current scope, test C102 + by calling 'check_import_status'. + (resolve_select_type): Test the declared derived type in TYPE + IS and CLASS IS statements. + +2025-07-08 Andre Vehreschild <vehre@gcc.gnu.org> + + PR fortran/120637 + * class.cc (finalize_component): Return true, when a finalizable + component was detect and do not free it. + 2025-07-07 Mikael Morin <mikael@gcc.gnu.org> * trans-intrinsic.cc (conv_intrinsic_move_alloc): Add pre and diff --git a/gcc/fortran/check.cc b/gcc/fortran/check.cc index 838d523..8626526 100644 --- a/gcc/fortran/check.cc +++ b/gcc/fortran/check.cc @@ -5559,6 +5559,27 @@ gfc_check_scan (gfc_expr *x, gfc_expr *y, gfc_expr *z, gfc_expr *kind) return true; } +bool +gfc_check_split (gfc_expr *string, gfc_expr *set, gfc_expr *pos, gfc_expr *back) +{ + if (!type_check (string, 0, BT_CHARACTER)) + return false; + + if (!type_check (set, 1, BT_CHARACTER)) + return false; + + if (!type_check (pos, 2, BT_INTEGER) || !scalar_check (pos, 2)) + return false; + + if (back != NULL + && (!type_check (back, 3, BT_LOGICAL) || !scalar_check (back, 3))) + return false; + + if (!same_type_check (string, 0, set, 1)) + return false; + + return true; +} bool gfc_check_secnds (gfc_expr *r) diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc index df18601..a1c6faf 100644 --- a/gcc/fortran/class.cc +++ b/gcc/fortran/class.cc @@ -1034,7 +1034,7 @@ comp_is_finalizable (gfc_component *comp) of calling the appropriate finalizers, coarray deregistering, and deallocation of allocatable subcomponents. */ -static void +static bool finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, gfc_symbol *stat, gfc_symbol *fini_coarray, gfc_code **code, gfc_namespace *sub_ns) @@ -1044,14 +1044,14 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, gfc_was_finalized *f; if (!comp_is_finalizable (comp)) - return; + return false; /* If this expression with this component has been finalized already in this namespace, there is nothing to do. */ for (f = sub_ns->was_finalized; f; f = f->next) { if (f->e == expr && f->c == comp) - return; + return false; } e = gfc_copy_expr (expr); @@ -1208,8 +1208,6 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, final_wrap->ext.actual->next->next = gfc_get_actual_arglist (); final_wrap->ext.actual->next->next->expr = fini_coarray_expr; - - if (*code) { (*code)->next = final_wrap; @@ -1221,11 +1219,14 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, else { gfc_component *c; + bool ret = false; for (c = comp->ts.u.derived->components; c; c = c->next) - finalize_component (e, comp->ts.u.derived, c, stat, fini_coarray, code, - sub_ns); - gfc_free_expr (e); + ret |= finalize_component (e, comp->ts.u.derived, c, stat, fini_coarray, + code, sub_ns); + /* Only free the expression, if it has never been used. */ + if (!ret) + gfc_free_expr (e); } /* Record that this was finalized already in this namespace. */ @@ -1234,6 +1235,7 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, sub_ns->was_finalized->e = expr; sub_ns->was_finalized->c = comp; sub_ns->was_finalized->next = f; + return true; } @@ -2314,6 +2316,7 @@ finish_assumed_rank: { gfc_symbol *stat; gfc_code *block = NULL; + gfc_expr *ptr_expr; if (!ptr) { @@ -2359,14 +2362,15 @@ finish_assumed_rank: sub_ns); block = block->next; + ptr_expr = gfc_lval_expr_from_sym (ptr); for (comp = derived->components; comp; comp = comp->next) { if (comp == derived->components && derived->attr.extension && ancestor_wrapper && ancestor_wrapper->expr_type != EXPR_NULL) continue; - finalize_component (gfc_lval_expr_from_sym (ptr), derived, comp, - stat, fini_coarray, &block, sub_ns); + finalize_component (ptr_expr, derived, comp, stat, fini_coarray, + &block, sub_ns); if (!last_code->block->next) last_code->block->next = block; } 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/decl.cc b/gcc/fortran/decl.cc index 69acd2d..af42575 100644 --- a/gcc/fortran/decl.cc +++ b/gcc/fortran/decl.cc @@ -1723,13 +1723,17 @@ build_sym (const char *name, int elem, gfc_charlen *cl, bool cl_deferred, symbol_attribute attr; gfc_symbol *sym; int upper; - gfc_symtree *st; + gfc_symtree *st, *host_st = NULL; /* Symbols in a submodule are host associated from the parent module or submodules. Therefore, they can be overridden by declarations in the submodule scope. Deal with this by attaching the existing symbol to a new symtree and recycling the old symtree with a new symbol... */ st = gfc_find_symtree (gfc_current_ns->sym_root, name); + if (((st && st->import_only) || (gfc_current_ns->import_state == IMPORT_ALL)) + && gfc_current_ns->parent) + host_st = gfc_find_symtree (gfc_current_ns->parent->sym_root, name); + if (st != NULL && gfc_state_stack->state == COMP_SUBMODULE && st->n.sym != NULL && st->n.sym->attr.host_assoc && st->n.sym->attr.used_in_submodule) @@ -1742,6 +1746,20 @@ build_sym (const char *name, int elem, gfc_charlen *cl, bool cl_deferred, sym->refs++; gfc_set_sym_referenced (sym); } + /* ...Check that F2018 IMPORT, ONLY and IMPORT, ALL statements, within the + current scope are not violated by local redeclarations. Note that there is + no need to guard for std >= F2018 because import_only and IMPORT_ALL are + only set for these standards. */ + else if (host_st && host_st->n.sym + && host_st->n.sym != gfc_current_ns->proc_name + && !(st && st->n.sym + && (st->n.sym->attr.dummy || st->n.sym->attr.result))) + { + gfc_error ("F2018: C8102 %s at %L is already imported by an %s " + "statement and must not be re-declared", name, var_locus, + (st && st->import_only) ? "IMPORT, ONLY" : "IMPORT, ALL"); + return false; + } /* ...Otherwise generate a new symtree and new symbol. */ else if (gfc_get_symbol (name, NULL, &sym, var_locus)) return false; @@ -5100,6 +5118,54 @@ error: } +/* Match the IMPORT statement. IMPORT was added to F2003 as + + R1209 import-stmt is IMPORT [[ :: ] import-name-list ] + + C1210 (R1209) The IMPORT statement is allowed only in an interface-body. + + C1211 (R1209) Each import-name shall be the name of an entity in the + host scoping unit. + + under the description of an interface block. Under F2008, IMPORT was + split out of the interface block description to 12.4.3.3 and C1210 + became + + C1210 (R1209) The IMPORT statement is allowed only in an interface-body + that is not a module procedure interface body. + + Finally, F2018, section 8.8, has changed the IMPORT statement to + + R867 import-stmt is IMPORT [[ :: ] import-name-list ] + or IMPORT, ONLY : import-name-list + or IMPORT, NONE + or IMPORT, ALL + + C896 (R867) An IMPORT statement shall not appear in the scoping unit of + a main-program, external-subprogram, module, or block-data. + + C897 (R867) Each import-name shall be the name of an entity in the host + scoping unit. + + C898 If any IMPORT statement in a scoping unit has an ONLY specifier, + all IMPORT statements in that scoping unit shall have an ONLY + specifier. + + C899 IMPORT, NONE shall not appear in the scoping unit of a submodule. + + C8100 If an IMPORT, NONE or IMPORT, ALL statement appears in a scoping + unit, no other IMPORT statement shall appear in that scoping unit. + + C8101 Within an interface body, an entity that is accessed by host + association shall be accessible by host or use association within + the host scoping unit, or explicitly declared prior to the interface + body. + + C8102 An entity whose name appears as an import-name or which is made + accessible by an IMPORT, ALL statement shall not appear in any + context described in 19.5.1.4 that would cause the host entity + of that name to be inaccessible. */ + match gfc_match_import (void) { @@ -5107,16 +5173,28 @@ gfc_match_import (void) match m; gfc_symbol *sym; gfc_symtree *st; + bool f2018_allowed = gfc_option.allow_std & ~GFC_STD_OPT_F08;; + importstate current_import_state = gfc_current_ns->import_state; - if (gfc_current_ns->proc_name == NULL - || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY) + if (!f2018_allowed + && (gfc_current_ns->proc_name == NULL + || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)) { gfc_error ("IMPORT statement at %C only permitted in " "an INTERFACE body"); return MATCH_ERROR; } + else if (f2018_allowed + && (!gfc_current_ns->parent || gfc_current_ns->is_block_data)) + goto C897; + + if (f2018_allowed + && (current_import_state == IMPORT_ALL + || current_import_state == IMPORT_NONE)) + goto C8100; - if (gfc_current_ns->proc_name->attr.module_procedure) + if (gfc_current_ns->proc_name + && gfc_current_ns->proc_name->attr.module_procedure) { gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted " "in a module procedure interface body"); @@ -5126,20 +5204,65 @@ gfc_match_import (void) if (!gfc_notify_std (GFC_STD_F2003, "IMPORT statement at %C")) return MATCH_ERROR; + gfc_current_ns->import_state = IMPORT_NOT_SET; + if (f2018_allowed) + { + if (gfc_match (" , none") == MATCH_YES) + { + if (current_import_state == IMPORT_ONLY) + goto C898; + if (gfc_current_state () == COMP_SUBMODULE) + goto C899; + gfc_current_ns->import_state = IMPORT_NONE; + } + else if (gfc_match (" , only :") == MATCH_YES) + { + if (current_import_state != IMPORT_NOT_SET + && current_import_state != IMPORT_ONLY) + goto C898; + gfc_current_ns->import_state = IMPORT_ONLY; + } + else if (gfc_match (" , all") == MATCH_YES) + { + if (current_import_state == IMPORT_ONLY) + goto C898; + gfc_current_ns->import_state = IMPORT_ALL; + } + + if (current_import_state != IMPORT_NOT_SET + && (gfc_current_ns->import_state == IMPORT_NONE + || gfc_current_ns->import_state == IMPORT_ALL)) + goto C8100; + } + + /* F2008 IMPORT<eos> is distinct from F2018 IMPORT, ALL. */ if (gfc_match_eos () == MATCH_YES) { - /* All host variables should be imported. */ - gfc_current_ns->has_import_set = 1; + /* This is the F2008 variant. */ + if (gfc_current_ns->import_state == IMPORT_NOT_SET) + { + if (current_import_state == IMPORT_ONLY) + goto C898; + gfc_current_ns->import_state = IMPORT_F2008; + } + + /* Host variables should be imported. */ + if (gfc_current_ns->import_state != IMPORT_NONE) + gfc_current_ns->has_import_set = 1; return MATCH_YES; } - if (gfc_match (" ::") == MATCH_YES) + if (gfc_match (" ::") == MATCH_YES + && gfc_current_ns->import_state != IMPORT_ONLY) { if (gfc_match_eos () == MATCH_YES) - { - gfc_error ("Expecting list of named entities at %C"); - return MATCH_ERROR; - } + goto expecting_list; + gfc_current_ns->import_state = IMPORT_F2008; + } + else if (gfc_current_ns->import_state == IMPORT_ONLY) + { + if (gfc_match_eos () == MATCH_YES) + goto expecting_list; } for(;;) @@ -5149,13 +5272,15 @@ gfc_match_import (void) switch (m) { case MATCH_YES: - if (gfc_current_ns->parent != NULL + if (gfc_current_ns->parent != NULL && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym)) { gfc_error ("Type name %qs at %C is ambiguous", name); return MATCH_ERROR; } - else if (!sym && gfc_current_ns->proc_name->ns->parent != NULL + else if (!sym + && gfc_current_ns->proc_name + && gfc_current_ns->proc_name->ns->parent && gfc_find_symbol (name, gfc_current_ns->proc_name->ns->parent, 1, &sym)) @@ -5166,12 +5291,29 @@ gfc_match_import (void) if (sym == NULL) { - gfc_error ("Cannot IMPORT %qs from host scoping unit " - "at %C - does not exist.", name); - return MATCH_ERROR; + if (gfc_current_ns->proc_name + && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY) + { + gfc_error ("Cannot IMPORT %qs from host scoping unit " + "at %C - does not exist.", name); + return MATCH_ERROR; + } + else + { + /* This might be a procedure that has not yet been parsed. If + so gfc_fixup_sibling_symbols will replace this symbol with + that of the procedure. */ + gfc_get_sym_tree (name, gfc_current_ns, &st, false, + &gfc_current_locus); + st->n.sym->refs++; + st->n.sym->attr.imported = 1; + st->import_only = 1; + goto next_item; + } } - if (gfc_find_symtree (gfc_current_ns->sym_root, name)) + st = gfc_find_symtree (gfc_current_ns->sym_root, name); + if (st && st->n.sym && st->n.sym->attr.imported) { gfc_warning (0, "%qs is already IMPORTed from host scoping unit " "at %C", name); @@ -5182,6 +5324,7 @@ gfc_match_import (void) st->n.sym = sym; sym->refs++; sym->attr.imported = 1; + st->import_only = 1; if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym))) { @@ -5193,6 +5336,7 @@ gfc_match_import (void) st->n.sym = sym; sym->refs++; sym->attr.imported = 1; + st->import_only = 1; } goto next_item; @@ -5216,6 +5360,34 @@ gfc_match_import (void) syntax: gfc_error ("Syntax error in IMPORT statement at %C"); return MATCH_ERROR; + +C897: + gfc_error ("F2018: C897 IMPORT statement at %C cannot appear in a main " + "program, an external subprogram, a module or block data"); + return MATCH_ERROR; + +C898: + gfc_error ("F2018: C898 IMPORT statement at %C is not permitted because " + "a scoping unit has an ONLY specifier, can only have IMPORT " + "with an ONLY specifier"); + return MATCH_ERROR; + +C899: + gfc_error ("F2018: C899 IMPORT, NONE shall not appear in the scoping unit" + " of a submodule as at %C"); + return MATCH_ERROR; + +C8100: + gfc_error ("F2018: C8100 IMPORT statement at %C is not permitted because " + "%s has already been declared, which must be unique in the " + "scoping unit", + gfc_current_ns->import_state == IMPORT_ALL ? "IMPORT, ALL" : + "IMPORT, NONE"); + return MATCH_ERROR; + +expecting_list: + gfc_error ("Expecting list of named entities at %C"); + return MATCH_ERROR; } 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 6848bd1..d9dcd1b 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -729,6 +729,8 @@ enum gfc_isym_id GFC_ISYM_COSPI, GFC_ISYM_SINPI, GFC_ISYM_TANPI, + + GFC_ISYM_SPLIT, }; enum init_local_logical @@ -2028,10 +2030,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. */ @@ -2188,6 +2186,7 @@ typedef struct gfc_symtree gfc_omp_udr *omp_udr; } n; + unsigned import_only:1; } gfc_symtree; @@ -2215,6 +2214,17 @@ typedef struct gfc_was_finalized { } gfc_was_finalized; + + /* Flag F2018 import status */ +enum importstate +{ IMPORT_NOT_SET = 0, /* Default condition. */ + IMPORT_F2008, /* Old style IMPORT. */ + IMPORT_ONLY, /* Import list used. */ + IMPORT_NONE, /* No host association. Unique in scoping unit. */ + IMPORT_ALL /* Must be unique in the scoping unit. */ +}; + + /* A namespace describes the contents of procedure, module, interface block or BLOCK construct. */ /* ??? Anything else use these? */ @@ -2328,6 +2338,10 @@ typedef struct gfc_namespace /* Set to 1 if namespace is an interface body with "IMPORT" used. */ unsigned has_import_set:1; + /* Flag F2018 import status */ + ENUM_BITFIELD (importstate) import_state :3; + + /* Set to 1 if the namespace uses "IMPLICIT NONE (export)". */ unsigned has_implicit_none_export:1; @@ -3582,11 +3596,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/interface.cc b/gcc/fortran/interface.cc index f74fbf0..d08f683 100644 --- a/gcc/fortran/interface.cc +++ b/gcc/fortran/interface.cc @@ -4781,6 +4781,13 @@ matching_typebound_op (gfc_expr** tb_base, gfc_actual_arglist* argcopy; bool matches; + /* If expression matching comes here during parsing, eg. when + parsing ASSOCIATE, generic TBPs have not yet been resolved + and g->specific will not have been set. Wait for expression + resolution by returning NULL. */ + if (!g->specific && !gfc_current_ns->resolved) + return NULL; + gcc_assert (g->specific); if (g->specific->error) continue; diff --git a/gcc/fortran/intrinsic.cc b/gcc/fortran/intrinsic.cc index 9e07627..c99a7a8 100644 --- a/gcc/fortran/intrinsic.cc +++ b/gcc/fortran/intrinsic.cc @@ -3933,6 +3933,14 @@ add_subroutines (void) pt, BT_INTEGER, di, OPTIONAL, INTENT_IN, gt, BT_INTEGER, di, OPTIONAL, INTENT_OUT); + add_sym_4s ("split", GFC_ISYM_SPLIT, CLASS_PURE, + BT_UNKNOWN, 0, GFC_STD_F2023, + gfc_check_split, NULL, gfc_resolve_split, + "string", BT_CHARACTER, dc, REQUIRED, INTENT_IN, + "set", BT_CHARACTER, dc, REQUIRED, INTENT_IN, + "pos", BT_INTEGER, di, REQUIRED, INTENT_INOUT, + "back", BT_LOGICAL, dl, OPTIONAL, INTENT_IN); + /* The following subroutines are part of ISO_C_BINDING. */ add_sym_3s ("c_f_pointer", GFC_ISYM_C_F_POINTER, CLASS_IMPURE, BT_UNKNOWN, 0, diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index fd54588..8a0ab93 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -215,6 +215,7 @@ bool gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, bool gfc_check_random_init (gfc_expr *, gfc_expr *); bool gfc_check_random_number (gfc_expr *); bool gfc_check_random_seed (gfc_expr *, gfc_expr *, gfc_expr *); +bool gfc_check_split (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_dtime_etime_sub (gfc_expr *, gfc_expr *); bool gfc_check_fgetputc_sub (gfc_expr *, gfc_expr *, gfc_expr *); bool gfc_check_fgetput_sub (gfc_expr *, gfc_expr *); @@ -693,6 +694,7 @@ void gfc_resolve_link_sub (gfc_code *); void gfc_resolve_symlnk_sub (gfc_code *); void gfc_resolve_signal_sub (gfc_code *); void gfc_resolve_sleep_sub (gfc_code *); +void gfc_resolve_split (gfc_code *); void gfc_resolve_stat_sub (gfc_code *); void gfc_resolve_system_clock (gfc_code *); void gfc_resolve_system_sub (gfc_code *); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 3103da3..a24b234 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -313,6 +313,7 @@ Some basic guidelines for editing this document: * @code{SIZEOF}: SIZEOF, Determine the size in bytes of an expression * @code{SLEEP}: SLEEP, Sleep for the specified number of seconds * @code{SPACING}: SPACING, Smallest distance between two numbers of a given type +* @code{SPLIT}: SPLIT, Parse a string into tokens, one at a time. * @code{SPREAD}: SPREAD, Add a dimension to an array * @code{SQRT}: SQRT, Square-root function * @code{SRAND}: SRAND, Reinitialize the random number generator @@ -14203,6 +14204,69 @@ Fortran 90 and later +@node SPLIT +@section @code{SPLIT} --- Parse a string into tokens, one at a time +@fnindex SPLIT +@cindex string, split + +@table @asis +@item @emph{Synopsis}: +@code{RESULT = SPLIT(STRING, SET, POS [, BACK])} + +@item @emph{Description}: +Updates the integer @var{POS} to the position of the next (or previous) +separator in @var{STRING}. + +If @var{BACK} is absent or is present with the value false, @var{POS} is +assigned the position of the leftmost token delimiter in @var{STRING} whose +position is greater than @var{POS}, or if there is no such character, it is +assigned a value one greater than the length of @var{STRING}. This identifies +a token with starting position one greater than the value of @var{POS} on +invocation, and ending position one less than the value of @var{POS} on return. + +If @var{BACK} is present with the value true, @var{POS} is assigned the +position of the rightmost token delimiter in @var{STRING} whose position is +less than @var{POS}, or if there is no such character, it is assigned the value +zero. This identifies a token with ending position one less than the value of +@var{POS} on invocation, and starting position one greater than the value of +@var{POS} on return. + +@item @emph{Class}: +Subroutine + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{STRING} @tab Shall be of type @code{CHARACTER}. +@item @var{SET} @tab Shall be of type @code{CHARACTER}. +@item @var{POS} @tab Shall be of type @code{INTEGER}. +@item @var{BACK} @tab (Optional) Shall be of type @code{LOGICAL}. +@end multitable + +@item @emph{Example}: +@smallexample +character(len=:), allocatable :: input +character(len=2) :: set = ', ' +integer :: p +input = "one,last example" +p = 0 +do + if (p > len(input)) exit + istart = p + 1 + call split(input, set, p) + iend = p - 1 + print '(t7, a)', input(istart:iend) +end do +@end smallexample + +@item @emph{Standard}: +Fortran 2023 + +@item @emph{See also}: +@ref{SCAN} +@end table + + + @node SPREAD @section @code{SPREAD} --- Add a dimension to an array @fnindex SPREAD diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi index da085d1..0b893e8 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -1170,6 +1170,10 @@ A @code{CHARACTER} variable is declared with negative length. With @option{-fopenmp}, for fixed-form source code, when an @code{omx} vendor-extension sentinel is encountered. (The equivalent @code{ompx}, used in free-form source code, is diagnosed by default.) + +@item +With @option{-fopenacc}, when using named constances with clauses that +take a variable as doing so has no effect. @end itemize @opindex Wtabs diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc index 1001309..da354ab 100644 --- a/gcc/fortran/iresolve.cc +++ b/gcc/fortran/iresolve.cc @@ -3863,6 +3863,19 @@ gfc_resolve_sleep_sub (gfc_code *c) c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); } +void +gfc_resolve_split (gfc_code *c) +{ + const char *name; + gfc_expr *string; + + string = c->ext.actual->expr; + if (string->ts.type == BT_CHARACTER && string->ts.kind == 4) + name = "__split_char4"; + else + name = "__split"; + c->resolved_sym = gfc_get_intrinsic_sub_symbol (name); +} /* G77 compatibility function srand(). */ diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc index fe0a47a..f1acc00 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -8895,15 +8895,21 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, if (list == OMP_LIST_MAP && n->sym->attr.flavor == FL_PARAMETER) { + /* OpenACC since 3.4 permits for Fortran named constants, but + permits removing then as optimization is not needed and such + ignore them. Likewise below for FIRSTPRIVATE. */ if (openacc) - gfc_error ("Object %qs is not a variable at %L; parameters" - " cannot be and need not be copied", n->sym->name, - &n->where); + gfc_warning (OPT_Wsurprising, "Clause for object %qs at %L is " + "ignored as parameters need not be copied", + n->sym->name, &n->where); else gfc_error ("Object %qs is not a variable at %L; parameters" " cannot be and need not be mapped", n->sym->name, &n->where); } + else if (openacc && n->sym->attr.flavor == FL_PARAMETER) + gfc_warning (OPT_Wsurprising, "Clause for object %qs at %L is ignored" + " as it is a parameter", n->sym->name, &n->where); else if (list != OMP_LIST_USES_ALLOCATORS) gfc_error ("Object %qs is not a variable at %L", n->sym->name, &n->where); @@ -12756,9 +12762,21 @@ gfc_resolve_oacc_declare (gfc_namespace *ns) && (n->sym->attr.flavor != FL_PROCEDURE || n->sym->result != n->sym)) { - gfc_error ("Object %qs is not a variable at %L", - n->sym->name, &oc->loc); - continue; + if (n->sym->attr.flavor != FL_PARAMETER) + { + gfc_error ("Object %qs is not a variable at %L", + n->sym->name, &oc->loc); + continue; + } + /* Note that OpenACC 3.4 permits name constants, but the + implementation is permitted to ignore the clause; + as semantically, device_resident kind of makes sense + (and the wording with it is a bit odd), the warning + is suppressed. */ + if (list != OMP_LIST_DEVICE_RESIDENT) + gfc_warning (OPT_Wsurprising, "Object %qs at %L is ignored as" + " parameters need not be copied", n->sym->name, + &oc->loc); } if (n->expr && n->expr->ref->type == REF_ARRAY) 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/parse.cc b/gcc/fortran/parse.cc index 8d4ca39..847ff37 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -6793,6 +6793,7 @@ gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings) gfc_namespace *ns; gfc_symtree *st; gfc_symbol *old_sym; + bool imported; for (ns = siblings; ns; ns = ns->sibling) { @@ -6808,6 +6809,7 @@ gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings) goto fixup_contained; old_sym = st->n.sym; + imported = old_sym->attr.imported == 1; if (old_sym->ns == ns && !old_sym->attr.contained @@ -6834,7 +6836,8 @@ gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings) /* Replace it with the symbol from the parent namespace. */ st->n.sym = sym; sym->refs++; - + if (imported) + sym->attr.imported = 1; gfc_release_symbol (old_sym); } diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 4a6e951..c33bd17 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -3919,10 +3919,153 @@ found: } + +static bool +check_sym_import_status (gfc_symbol *sym, gfc_symtree *s, gfc_expr *e, + gfc_code *c, gfc_namespace *ns) +{ + locus *here; + + /* If the type has been imported then its vtype functions are OK. */ + if (e && e->expr_type == EXPR_FUNCTION && sym->attr.vtype) + return true; + + if (e) + here = &e->where; + else + here = &c->loc; + + if (s && !s->import_only) + s = gfc_find_symtree (ns->sym_root, sym->name); + + if (ns->import_state == IMPORT_ONLY + && sym->ns != ns + && (!s || !s->import_only)) + { + gfc_error ("F2018: C8102 %qs at %L is host associated but does not " + "appear in an IMPORT or IMPORT, ONLY list", sym->name, here); + return false; + } + else if (ns->import_state == IMPORT_NONE + && sym->ns != ns) + { + gfc_error ("F2018: C8102 %qs at %L is host associated in a scope that " + "has IMPORT, NONE", sym->name, here); + return false; + } + return true; +} + + +static bool +check_import_status (gfc_expr *e) +{ + gfc_symtree *st; + gfc_ref *ref; + gfc_symbol *sym, *der; + gfc_namespace *ns = gfc_current_ns; + + switch (e->expr_type) + { + case EXPR_VARIABLE: + case EXPR_FUNCTION: + case EXPR_SUBSTRING: + sym = e->symtree ? e->symtree->n.sym : NULL; + + /* Check the symbol itself. */ + if (sym + && !(ns->proc_name + && (sym == ns->proc_name)) + && !check_sym_import_status (sym, e->symtree, e, NULL, ns)) + return false; + + /* Check the declared derived type. */ + if (sym->ts.type == BT_DERIVED) + { + der = sym->ts.u.derived; + st = gfc_find_symtree (ns->sym_root, der->name); + + if (!check_sym_import_status (der, st, e, NULL, ns)) + return false; + } + else if (sym->ts.type == BT_CLASS && !UNLIMITED_POLY (sym)) + { + der = CLASS_DATA (sym) ? CLASS_DATA (sym)->ts.u.derived + : sym->ts.u.derived; + st = gfc_find_symtree (ns->sym_root, der->name); + + if (!check_sym_import_status (der, st, e, NULL, ns)) + return false; + } + + /* Check the declared derived types of component references. */ + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + { + gfc_component *c = ref->u.c.component; + if (c->ts.type == BT_DERIVED) + { + der = c->ts.u.derived; + st = gfc_find_symtree (ns->sym_root, der->name); + if (!check_sym_import_status (der, st, e, NULL, ns)) + return false; + } + else if (c->ts.type == BT_CLASS && !UNLIMITED_POLY (c)) + { + der = CLASS_DATA (c) ? CLASS_DATA (c)->ts.u.derived + : c->ts.u.derived; + st = gfc_find_symtree (ns->sym_root, der->name); + if (!check_sym_import_status (der, st, e, NULL, ns)) + return false; + } + } + + break; + + case EXPR_ARRAY: + case EXPR_STRUCTURE: + /* Check the declared derived type. */ + if (e->ts.type == BT_DERIVED) + { + der = e->ts.u.derived; + st = gfc_find_symtree (ns->sym_root, der->name); + + if (!check_sym_import_status (der, st, e, NULL, ns)) + return false; + } + else if (e->ts.type == BT_CLASS && !UNLIMITED_POLY (e)) + { + der = CLASS_DATA (e) ? CLASS_DATA (e)->ts.u.derived + : e->ts.u.derived; + st = gfc_find_symtree (ns->sym_root, der->name); + + if (!check_sym_import_status (der, st, e, NULL, ns)) + return false; + } + + break; + +/* Either not applicable or resolved away + case EXPR_OP: + case EXPR_UNKNOWN: + case EXPR_CONSTANT: + case EXPR_NULL: + case EXPR_COMPCALL: + case EXPR_PPC: */ + + default: + break; + } + + return true; +} + + /* Resolve a subroutine call. Although it was tempting to use the same code for functions, subroutines and functions are stored differently and this makes things awkward. */ + static bool resolve_call (gfc_code *c) { @@ -4080,6 +4223,11 @@ resolve_call (gfc_code *c) "Using subroutine %qs at %L is deprecated", c->resolved_sym->name, &c->loc); + csym = c->resolved_sym ? c->resolved_sym : csym; + if (t && gfc_current_ns->import_state != IMPORT_NOT_SET && !c->resolved_isym + && csym != gfc_current_ns->proc_name) + return check_sym_import_status (csym, c->symtree, NULL, c, gfc_current_ns); + return t; } @@ -7792,6 +7940,7 @@ fixup_unique_dummy (gfc_expr *e) e->symtree = st; } + /* Resolve an expression. That is, make sure that types of operands agree with their operators, intrinsic operators are converted to function calls for overloaded types and unresolved function references are resolved. */ @@ -7919,6 +8068,9 @@ gfc_resolve_expr (gfc_expr *e) && UNLIMITED_POLY (e->symtree->n.sym)) e->do_not_resolve_again = 1; + if (t && gfc_current_ns->import_state != IMPORT_NOT_SET) + t = check_import_status (e); + return t; } @@ -10572,6 +10724,7 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) int rank = 0, corank = 0; gfc_ref* ref = NULL; gfc_expr *selector_expr = NULL; + gfc_code *old_code = code; ns = code->ext.block.ns; if (code->expr2) @@ -10860,6 +11013,18 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) when this case is actually true, so build a new ASSOCIATE that does precisely this here (instead of using the 'global' one). */ + + /* First check the derived type import status. */ + if (gfc_current_ns->import_state != IMPORT_NOT_SET + && (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)) + { + st = gfc_find_symtree (gfc_current_ns->sym_root, + c->ts.u.derived->name); + if (!check_sym_import_status (c->ts.u.derived, st, NULL, old_code, + gfc_current_ns)) + error++; + } + const char * var_name = gfc_var_name_for_select_type_temp (orig_expr1); if (c->ts.type == BT_CLASS) snprintf (name, sizeof (name), "__tmp_class_%s_%s", diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 7be2d7b..990aaaf 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -1426,12 +1426,6 @@ get_class_info_from_ss (stmtblock_t * pre, gfc_ss *ss, tree *eltype, tmp2 = gfc_class_len_get (class_expr); gfc_add_modify (pre, tmp, tmp2); } - - if (rhs_function) - { - tmp = gfc_class_data_get (class_expr); - gfc_conv_descriptor_offset_set (pre, tmp, gfc_index_zero_node); - } } else if (rhs_ss->info->data.array.descriptor) { @@ -3372,18 +3366,51 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, break; case GFC_SS_FUNCTION: - /* Array function return value. We call the function and save its - result in a temporary for use inside the loop. */ - gfc_init_se (&se, NULL); - se.loop = loop; - se.ss = ss; - if (gfc_is_class_array_function (expr)) - expr->must_finalize = 1; - 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; + { + /* Array function return value. We call the function and save its + result in a temporary for use inside the loop. */ + gfc_init_se (&se, NULL); + se.loop = loop; + se.ss = ss; + bool class_func = gfc_is_class_array_function (expr); + if (class_func) + expr->must_finalize = 1; + gfc_conv_expr (&se, expr); + gfc_add_block_to_block (&outer_loop->pre, &se.pre); + if (class_func + && se.expr + && GFC_CLASS_TYPE_P (TREE_TYPE (se.expr))) + { + tree tmp = gfc_class_data_get (se.expr); + info->descriptor = tmp; + info->data = gfc_conv_descriptor_data_get (tmp); + info->offset = gfc_conv_descriptor_offset_get (tmp); + for (gfc_ss *s = ss; s; s = s->parent) + for (int n = 0; n < s->dimen; n++) + { + int dim = s->dim[n]; + tree tree_dim = gfc_rank_cst[dim]; + + tree start; + start = gfc_conv_descriptor_lbound_get (tmp, tree_dim); + start = gfc_evaluate_now (start, &outer_loop->pre); + info->start[dim] = start; + + tree end; + end = gfc_conv_descriptor_ubound_get (tmp, tree_dim); + end = gfc_evaluate_now (end, &outer_loop->pre); + info->end[dim] = end; + + tree stride; + stride = gfc_conv_descriptor_stride_get (tmp, tree_dim); + stride = gfc_evaluate_now (stride, &outer_loop->pre); + info->stride[dim] = stride; + } + } + 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; case GFC_SS_CONSTRUCTOR: @@ -3420,6 +3447,183 @@ gfc_add_loop_ss_code (gfc_loopinfo * loop, gfc_ss * ss, bool subscript, } +/* Given an array descriptor expression DESCR and its data pointer DATA, decide + whether to either save the data pointer to a variable and use the variable or + use the data pointer expression directly without any intermediary variable. + */ + +static bool +save_descriptor_data (tree descr, tree data) +{ + return !(DECL_P (data) + || (TREE_CODE (data) == ADDR_EXPR + && DECL_P (TREE_OPERAND (data, 0))) + || (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (descr)) + && TREE_CODE (descr) == COMPONENT_REF + && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (descr, 0))))); +} + + +/* 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*/ @@ -3440,7 +3644,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; @@ -3466,17 +3670,14 @@ gfc_conv_ss_descriptor (stmtblock_t * block, gfc_ss * ss, int base) Otherwise we must evaluate it now to avoid breaking dependency analysis by pulling the expressions for elemental array indices inside the loop. */ - if (!(DECL_P (tmp) - || (TREE_CODE (tmp) == ADDR_EXPR - && 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)))))) + if (save_descriptor_data (se.expr, tmp) && !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 +4970,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 +5001,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 +5035,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 +5057,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; } } @@ -5205,7 +5410,8 @@ done: int dim = ss->dim[n]; info->start[dim] = gfc_index_zero_node; - info->end[dim] = gfc_index_zero_node; + if (ss_info->type != GFC_SS_FUNCTION) + info->end[dim] = gfc_index_zero_node; info->stride[dim] = gfc_index_one_node; } break; @@ -5890,6 +6096,46 @@ set_loop_bounds (gfc_loopinfo *loop) } +/* Last attempt to set the loop bounds, in case they depend on an allocatable + function result. */ + +static void +late_set_loop_bounds (gfc_loopinfo *loop) +{ + int n, dim; + gfc_array_info *info; + gfc_ss **loopspec; + + loopspec = loop->specloop; + + for (n = 0; n < loop->dimen; n++) + { + /* Set the extents of this range. */ + if (loop->from[n] == NULL_TREE + || loop->to[n] == NULL_TREE) + { + /* We should have found the scalarization loop specifier. If not, + that's bad news. */ + gcc_assert (loopspec[n]); + + info = &loopspec[n]->info->data.array; + dim = loopspec[n]->dim[n]; + + if (loopspec[n]->info->type == GFC_SS_FUNCTION + && info->start[dim] + && info->end[dim]) + { + loop->from[n] = info->start[dim]; + loop->to[n] = info->end[dim]; + } + } + } + + for (loop = loop->nested; loop; loop = loop->next) + late_set_loop_bounds (loop); +} + + /* Initialize the scalarization loop. Creates the loop variables. Determines the range of the loop variables. Creates a temporary if required. Also generates code for scalar expressions which have been @@ -5908,6 +6154,8 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where) allocating the temporary. */ gfc_add_loop_ss_code (loop, loop->ss, false, where); + late_set_loop_bounds (loop); + tmp_ss = loop->temp_ss; /* If we want a temporary then create it. */ if (tmp_ss != NULL) @@ -5964,9 +6212,11 @@ gfc_set_delta (gfc_loopinfo *loop) gfc_ss_type ss_type; ss_type = ss->info->type; - if (ss_type != GFC_SS_SECTION - && ss_type != GFC_SS_COMPONENT - && ss_type != GFC_SS_CONSTRUCTOR) + if (!(ss_type == GFC_SS_SECTION + || ss_type == GFC_SS_COMPONENT + || ss_type == GFC_SS_CONSTRUCTOR + || (ss_type == GFC_SS_FUNCTION + && gfc_is_class_array_function (ss->info->expr)))) continue; info = &ss->info->data.array; @@ -5991,7 +6241,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); } } } @@ -6115,8 +6368,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_desc, bool e3_has_nodescriptor, gfc_expr *expr, + tree expr3_elem_size, gfc_expr *expr3, tree expr3_desc, + bool e3_has_nodescriptor, gfc_expr *expr, tree *element_size, bool explicit_ts) { tree type; @@ -6392,7 +6645,6 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, if (rank == 0) return *element_size; - *nelems = gfc_evaluate_now (stride, pblock); stride = fold_convert (size_type_node, stride); /* First check for overflow. Since an array of type character can @@ -6481,9 +6733,8 @@ retrieve_last_ref (gfc_ref **ref_in, gfc_ref **prev_ref_in) 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 e3_arr_desc, - bool e3_has_nodescriptor, gfc_omp_namelist *omp_alloc, - bool explicit_ts) + gfc_expr *expr3, tree e3_arr_desc, bool e3_has_nodescriptor, + gfc_omp_namelist *omp_alloc, bool explicit_ts) { tree tmp; tree pointer; @@ -6614,7 +6865,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, coarray ? ref->u.ar.as->corank : 0, &offset, lower, upper, &se->pre, &set_descriptor_block, &overflow, - expr3_elem_size, nelems, expr3, e3_arr_desc, + expr3_elem_size, expr3, e3_arr_desc, e3_has_nodescriptor, expr, &element_size, explicit_ts); @@ -6779,8 +7030,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 +8719,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 +11455,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 +11582,55 @@ concat_str_length (gfc_expr* expr) } +/* Among the scalarization chain of LOOP, find the element associated with an + allocatable array on the lhs of an assignment and evaluate its fields + (bounds, offset, etc) to new variables, putting the new code in BLOCK. This + function is to be called after putting the reallocation code in BLOCK and + before the beginning of the scalarization loop body. + + The fields to be saved are expected to hold on entry to the function + expressions referencing the array descriptor. Especially the expressions + shouldn't be already temporary variable references as the value saved before + reallocation would be incorrect after reallocation. + At the end of the function, the expressions have been replaced with variable + references. */ + +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; + +#define SAVE_VALUE(value) \ + do \ + { \ + value = gfc_evaluate_now (value, block); \ + } \ + while (0) + + if (save_descriptor_data (info->descriptor, info->data)) + SAVE_VALUE (info->data); + SAVE_VALUE (info->offset); + info->saved_offset = info->offset; + for (int i = 0; i < s->dimen; i++) + { + int dim = s->dim[i]; + SAVE_VALUE (info->start[dim]); + SAVE_VALUE (info->end[dim]); + SAVE_VALUE (info->stride[dim]); + SAVE_VALUE (info->delta[dim]); + } + +#undef SAVE_VALUE + } +} + + /* Allocate the lhs of an assignment to an allocatable array, otherwise reallocate it. */ @@ -11368,7 +11669,6 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, tree lbd; tree class_expr2 = NULL_TREE; int n; - int dim; gfc_array_spec * as; bool coarray = (flag_coarray == GFC_FCOARRAY_LIB && gfc_caf_attr (expr1, true).codimension); @@ -11423,14 +11723,61 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, && !expr2->value.function.isym) expr2->ts.u.cl->backend_decl = rss->info->string_length; - gfc_start_block (&fblock); - /* Since the lhs is allocatable, this must be a descriptor type. Get the data and array size. */ desc = linfo->descriptor; gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))); array1 = gfc_conv_descriptor_data_get (desc); + /* If the data is null, set the descriptor bounds and offset. This suppresses + the maybe used uninitialized warning. Note that the always false variable + prevents this block from ever being executed, and makes sure that the + optimizers are able to remove it. Component references are not subject to + the warnings, so we don't uselessly complicate the generated code for them. + */ + for (ref = expr1->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + break; + + if (!ref) + { + stmtblock_t unalloc_init_block; + gfc_init_block (&unalloc_init_block); + tree guard = gfc_create_var (logical_type_node, "unallocated_init_guard"); + gfc_add_modify (&unalloc_init_block, guard, logical_false_node); + + 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 = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + logical_type_node, tmp, guard); + 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); + gfc_prepend_expr_to_block (&loop->pre, + gfc_finish_block (&unalloc_init_block)); + } + + gfc_start_block (&fblock); + if (expr2) desc2 = rss->info->data.array.descriptor; else @@ -11543,45 +11890,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,21 +12044,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++) - { - tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]); - dim = lss->dim[n]; - 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 for array descriptors and allocation sizes are computed correctly. */ @@ -11972,18 +12265,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-array.h b/gcc/fortran/trans-array.h index 1bb3294..29098fd 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -20,9 +20,8 @@ along with GCC; see the file COPYING3. If not see /* Generate code to initialize and allocate an array. Statements are added to se, which should contain an expression for the array descriptor. */ -bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree, - tree, tree *, gfc_expr *, tree, bool, - gfc_omp_namelist *, bool); +bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree, tree, + gfc_expr *, tree, bool, gfc_omp_namelist *, bool); /* Allow the bounds of a loop to be set from a callee's array spec. */ void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *, diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index 43bd7be..3b49b18 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -197,6 +197,7 @@ tree gfor_fndecl_string_scan; tree gfor_fndecl_string_verify; tree gfor_fndecl_string_trim; tree gfor_fndecl_string_minmax; +tree gfor_fndecl_string_split; tree gfor_fndecl_adjustl; tree gfor_fndecl_adjustr; tree gfor_fndecl_select_string; @@ -208,6 +209,7 @@ tree gfor_fndecl_string_scan_char4; tree gfor_fndecl_string_verify_char4; tree gfor_fndecl_string_trim_char4; tree gfor_fndecl_string_minmax_char4; +tree gfor_fndecl_string_split_char4; tree gfor_fndecl_adjustl_char4; tree gfor_fndecl_adjustr_char4; tree gfor_fndecl_select_string_char4; @@ -3569,6 +3571,12 @@ gfc_build_intrinsic_function_decls (void) build_pointer_type (pchar1_type_node), integer_type_node, integer_type_node); + gfor_fndecl_string_split = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX ("string_split")), ". . R . R . . ", + gfc_charlen_type_node, 6, gfc_charlen_type_node, pchar1_type_node, + gfc_charlen_type_node, pchar1_type_node, gfc_charlen_type_node, + gfc_logical4_type_node); + gfor_fndecl_adjustl = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("adjustl")), ". W . R ", void_type_node, 3, pchar1_type_node, gfc_charlen_type_node, @@ -3641,6 +3649,12 @@ gfc_build_intrinsic_function_decls (void) build_pointer_type (pchar4_type_node), integer_type_node, integer_type_node); + gfor_fndecl_string_split_char4 = gfc_build_library_function_decl_with_spec ( + get_identifier (PREFIX ("string_split_char4")), ". . R . R . . ", + gfc_charlen_type_node, 6, gfc_charlen_type_node, pchar4_type_node, + gfc_charlen_type_node, pchar4_type_node, gfc_charlen_type_node, + gfc_logical4_type_node); + gfor_fndecl_adjustl_char4 = gfc_build_library_function_decl_with_spec ( get_identifier (PREFIX("adjustl_char4")), ". W . R ", void_type_node, 3, pchar4_type_node, gfc_charlen_type_node, @@ -4773,14 +4787,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); + } } @@ -5326,7 +5340,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) continue; /* 'omp allocate( {purpose: allocator, value: align}, {purpose: init-stmtlist, value: cleanup-stmtlist}, - {purpose: size-var, value: last-size-expr}} + {purpose: size-var, value: last-size-expr} ) where init-stmt/cleanup-stmt is the STATEMENT list to find the try-final block; last-size-expr is to find the location after which to add the code and 'size-var' is for the proper size, cf. diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 3e0d763..ec24084 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))) @@ -5464,16 +5485,6 @@ gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77, /* Translate the expression. */ gfc_conv_expr (&rse, expr); - /* Reset the offset for the function call since the loop - is zero based on the data pointer. Note that the temp - comes first in the loop chain since it is added second. */ - if (gfc_is_class_array_function (expr)) - { - tmp = loop.ss->loop_chain->info->data.array.descriptor; - gfc_conv_descriptor_offset_set (&loop.pre, tmp, - gfc_index_zero_node); - } - gfc_conv_tmp_array_ref (&lse); if (intent != INTENT_OUT) @@ -7909,21 +7920,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 +8170,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 @@ -8842,28 +8854,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr)) && expr->must_finalize) { - int n; - if (se->ss && se->ss->loop) - { - gfc_add_block_to_block (&se->ss->loop->pre, &se->pre); - se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre); - tmp = gfc_class_data_get (se->expr); - info->descriptor = tmp; - info->data = gfc_conv_descriptor_data_get (tmp); - info->offset = gfc_conv_descriptor_offset_get (tmp); - for (n = 0; n < se->ss->loop->dimen; n++) - { - tree dim = gfc_rank_cst[n]; - se->ss->loop->to[n] = gfc_conv_descriptor_ubound_get (tmp, dim); - se->ss->loop->from[n] = gfc_conv_descriptor_lbound_get (tmp, dim); - } - } - else - { - /* TODO Eliminate the doubling of temporaries. This - one is necessary to ensure no memory leakage. */ - se->expr = gfc_evaluate_now (se->expr, &se->pre); - } + /* TODO Eliminate the doubling of temporaries. This + one is necessary to ensure no memory leakage. */ + se->expr = gfc_evaluate_now (se->expr, &se->pre); /* Finalize the result, if necessary. */ attr = expr->value.function.esym @@ -12870,16 +12863,19 @@ 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; - 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; @@ -12927,11 +12923,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. */ @@ -12943,6 +12934,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 +12953,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 +13007,15 @@ 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 +13324,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; diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index be98427..f68ceb1 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -3466,6 +3466,74 @@ else return gfc_finish_block (&block); } +static tree +conv_intrinsic_split (gfc_code *code) +{ + stmtblock_t block, post_block; + gfc_se se; + gfc_expr *string_expr, *set_expr, *pos_expr, *back_expr; + tree string, string_len; + tree set, set_len; + tree pos, pos_for_call; + tree back; + tree fndecl, call; + + string_expr = code->ext.actual->expr; + set_expr = code->ext.actual->next->expr; + pos_expr = code->ext.actual->next->next->expr; + back_expr = code->ext.actual->next->next->next->expr; + + gfc_start_block (&block); + gfc_init_block (&post_block); + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, string_expr); + gfc_conv_string_parameter (&se); + gfc_add_block_to_block (&block, &se.pre); + gfc_add_block_to_block (&post_block, &se.post); + string = se.expr; + string_len = se.string_length; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, set_expr); + gfc_conv_string_parameter (&se); + gfc_add_block_to_block (&block, &se.pre); + gfc_add_block_to_block (&post_block, &se.post); + set = se.expr; + set_len = se.string_length; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, pos_expr); + gfc_add_block_to_block (&block, &se.pre); + gfc_add_block_to_block (&post_block, &se.post); + pos = se.expr; + pos_for_call = fold_convert (gfc_charlen_type_node, pos); + + if (back_expr) + { + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, back_expr); + gfc_add_block_to_block (&block, &se.pre); + gfc_add_block_to_block (&post_block, &se.post); + back = se.expr; + } + else + back = logical_false_node; + + if (string_expr->ts.kind == 1) + fndecl = gfor_fndecl_string_split; + else if (string_expr->ts.kind == 4) + fndecl = gfor_fndecl_string_split_char4; + else + gcc_unreachable (); + + call = build_call_expr_loc (input_location, fndecl, 6, string_len, string, + set_len, set, pos_for_call, back); + gfc_add_modify (&block, pos, fold_convert (TREE_TYPE (pos), call)); + + gfc_add_block_to_block (&block, &post_block); + return gfc_finish_block (&block); +} /* Return a character string containing the tty name. */ @@ -13261,6 +13329,10 @@ gfc_conv_intrinsic_subroutine (gfc_code *code) res = conv_intrinsic_system_clock (code); break; + case GFC_ISYM_SPLIT: + res = conv_intrinsic_split (code); + break; + default: res = NULL_TREE; break; diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc index a2e70fc..278e91c 100644 --- a/gcc/fortran/trans-openmp.cc +++ b/gcc/fortran/trans-openmp.cc @@ -2792,8 +2792,13 @@ gfc_trans_omp_variable_list (enum omp_clause_code code, gfc_omp_namelist *namelist, tree list, bool declare_simd) { + /* PARAMETER (named constants) are excluded as OpenACC 3.4 permits them now + as 'var' but permits compilers to ignore them. In expressions, it should + have been replaced by the value (and this function should not be called + anyway) and for var-using clauses, they should just be skipped. */ for (; namelist != NULL; namelist = namelist->next) - if (namelist->sym->attr.referenced || declare_simd) + if ((namelist->sym->attr.referenced || declare_simd) + && namelist->sym->attr.flavor != FL_PARAMETER) { tree t = gfc_trans_omp_variable (namelist->sym, declare_simd); if (t != error_mark_node) @@ -4029,7 +4034,8 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, case OMP_LIST_MAP: for (; n != NULL; n = n->next) { - if (!n->sym->attr.referenced) + if (!n->sym->attr.referenced + || n->sym->attr.flavor == FL_PARAMETER) continue; location_t map_loc = gfc_get_location (&n->where); @@ -4986,7 +4992,8 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, case OMP_LIST_CACHE: for (; n != NULL; n = n->next) { - if (!n->sym->attr.referenced) + if (!n->sym->attr.referenced + && n->sym->attr.flavor != FL_PARAMETER) continue; switch (list) @@ -9707,11 +9714,12 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns, gfc_namespace *parent_ns) { gfc_symtree *proc_st; gfc_find_sym_tree (variant_proc_name, gfc_current_ns, 1, &proc_st); - variant_proc_sym = proc_st->n.sym; + variant_proc_sym = proc_st ? proc_st->n.sym : NULL; } if (variant_proc_sym == NULL) { - gfc_error ("Cannot find symbol %qs", variant_proc_name); + gfc_error ("Cannot find symbol %qs at %L", variant_proc_name, + &odv->where); continue; } set_selectors = omp_check_context_selector diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index f105401..b4ddf75 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -6710,7 +6710,6 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate) 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; bool e3_has_nodescriptor = false; @@ -7242,7 +7241,6 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate) to handle the complete array allocation. Only the element size needs to be provided, which is done most of the time by the pre-evaluation step. */ - nelems = NULL_TREE; if (expr3_len && (code->expr3->ts.type == BT_CHARACTER || code->expr3->ts.type == BT_CLASS)) { @@ -7313,9 +7311,8 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate) } - if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, - label_finish, tmp, &nelems, - e3rhs ? e3rhs : code->expr3, + if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish, + tmp, e3rhs ? e3rhs : code->expr3, e3_is == E3_DESC ? expr3 : NULL_TREE, e3_has_nodescriptor, omp_alloc_item, code->ext.alloc.ts.type != BT_UNKNOWN)) diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 461b0cd..40680e9 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -961,6 +961,7 @@ extern GTY(()) tree gfor_fndecl_string_scan; extern GTY(()) tree gfor_fndecl_string_verify; extern GTY(()) tree gfor_fndecl_string_trim; extern GTY(()) tree gfor_fndecl_string_minmax; +extern GTY(()) tree gfor_fndecl_string_split; extern GTY(()) tree gfor_fndecl_adjustl; extern GTY(()) tree gfor_fndecl_adjustr; extern GTY(()) tree gfor_fndecl_select_string; @@ -972,6 +973,7 @@ extern GTY(()) tree gfor_fndecl_string_scan_char4; extern GTY(()) tree gfor_fndecl_string_verify_char4; extern GTY(()) tree gfor_fndecl_string_trim_char4; extern GTY(()) tree gfor_fndecl_string_minmax_char4; +extern GTY(()) tree gfor_fndecl_string_split_char4; extern GTY(()) tree gfor_fndecl_adjustl_char4; extern GTY(()) tree gfor_fndecl_adjustr_char4; extern GTY(()) tree gfor_fndecl_select_string_char4; |